' Save this file to disk, In excel choose:
'   Tools -> Macros -> "Visual Basic Editor"
' Right click on "VBA Project (Personal.XLS)"
' Choose "Import File"
' Choose Tools -> References, check "Microsoft Forms 2.0 Object Library" and click OK
' Exit the window by clicking on the X decoration at the upper right,
'   or use Alt-Q, or choose File -> return to excel.
'
' Because you added this macro to your personal.XLS, it will
'   be available for all the spreadsheets you open.
'
' To export the current spreadsheet in TWiki format into the clipboard type Alt-F8 and
'    choose ExportDBToTWiki.
' To upload simply paste into the TWiki edit window.

Sub ExportDBToTWiki()

' This macro saves the active worksheet to a pipe-delimited flat file
' with a user choosable file. It does not clear embedded
' pipe characters.

' Updated 8/14/2003 to also strip those pesky ALT-ENTER chars that Excel allows within a cell
' ALT-ENTER embeds a CHR$(10) - the added code strips these out and replaces with a space.
' Also, changed GetSaveAsFilename so that the save dir was whever you saved to last - just in case
' you have a lot of tabbed sheets to convert!

' Updated 11/3/2004 to put asterisks around bold cells.

' Updated 6/13/2006 to center and right align fromatted cells, right align numeric fields
' and use CurrCell.Text instead of CurrCell.Value to retain numeric formatting.

' Updated 11/4/2006 to add Hyperlink support.

' Updated 5th June 2007 for MS Excel 2003:
'    fixed issues with merged cells
'    added coloured text conversion
'    added replacement of pipe character (prevent issues in TWiki tables)
'    added handling of strikethrough text
'    tidied variable usage

Dim SrcRg As Range
Dim CurrRow As Range
Dim CurrCell As Range
Dim CurrTextStr As String
Dim TextWithURL As String
Dim ListSep As String
Dim BoldChar As String
Dim ItalicChar As String
Dim FontChar As String
Dim AlignChar As String
Dim DataTextStr As String
Dim FileName As String
Dim TempChar As String
Dim TempCharCode As Integer
Dim TempString As String
Dim HardReturn As String
Dim HardReturnCode As Integer
Dim NewLine As String
Dim i As Integer
Dim xColor As String
Dim EndColor As String
Dim ColorText As String
Dim Strike As String
Dim EndStrike As String
Dim StrikeText As String
Dim PipeChar As String

ListSep = "|"
BoldChar = "*"
AlignChar = "  "
ItalicChar = "_"
HardReturn = Chr$(10)
NewLine = Chr$(13) & Chr$(10)
EndColor = "%ENDCOLOR%"
Strike = "<strike>"
EndStrike = "</strike>"
PipeChar = "&#124;"

Set SrcRg = ActiveSheet.UsedRange

For Each CurrRow In SrcRg.Rows
  CurrTextStr = ListSep

  For Each CurrCell In CurrRow.Cells
    If (CurrCell.MergeCells And (Not CurrCell.MergeArea.Column = CurrCell.Column)) Then
      ' Force empty cell contents for merged cells
      CurrTextStr = CurrTextStr & ListSep
      ' For merge cells,use of multi-span for rows 
    ElseIf (CurrCell.MergeCells And (CurrCell.MergeArea.Column = CurrCell.Column) And (CurrCell.Text = "")) Then
      CurrTextStr = CurrTextStr & "^" & ListSep
    ElseIf (CurrCell.Text = "") Then
      ' two || next to each other spans columns. Add a space
      ' if the value is empty so that we preserve the column
      ' format
      CurrTextStr = CurrTextStr & " " & ListSep
    Else
      If (CurrCell.Font.Bold) Then
        FontChar = BoldChar
      ElseIf (CurrCell.Font.Italic) Then
        FontChar = ItalicChar
      Else
        FontChar = ""
      End If
      
      ' Look for occurrances of pipe (used as TWiki table separator) in the cell data, replace with ASCII
      TempString = ""
      For i = 1 To Len(CurrCell.Text)
        TempChar = Mid(CurrCell.Text, i, 1)
        If TempChar = ListSep Then
          TempString = TempString & PipeChar
        Else
          TempString = TempString & TempChar
        End If
      Next i
  
      ' If text color is not black, convert to HTML color code
      If (Not CurrCell.Font.Color = RGB(0, 0, 0)) Then
        xColor = Right("000000" & Hex(CurrCell.Font.Color), 6)
        TempString = "<font color=#" & Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2) & ">" & TempString & EndColor
      End If
      
      ' Copy strikethrough formatting
      If (CurrCell.Font.Strikethrough) Then
        TempString = Strike & TempString & EndStrike
      End If
    
      ' Add URL codes
      If (CurrCell.Hyperlinks.Count = 1) Then
        URLCharLeft = "["
        URLCharRight = "]"
        TempString = URLCharLeft & URLCharLeft & CurrCell.Hyperlinks(1).Address & URLCharRight & URLCharLeft & TempString & URLCharRight & URLCharRight
      End If
      
      If CurrCell.HorizontalAlignment = xlCenter Then
        ' Center column and add font
        CurrTextStr = CurrTextStr & AlignChar & FontChar & TempString & FontChar & AlignChar & ListSep
      ElseIf CurrCell.HorizontalAlignment = xlRight Or IsNumeric(CurrCell.Value) Then
        ' Right align column and add font
        CurrTextStr = CurrTextStr & AlignChar & FontChar & TempString & FontChar & ListSep
      Else
        CurrTextStr = CurrTextStr & FontChar & TempString & FontChar & ListSep
      End If
    End If
    Next
    
  ' Look for occurrances of hard-returns in the cell data, replace with a space
  TempString = ""
  For i = 1 To Len(CurrTextStr)
    TempChar = Mid(CurrTextStr, i, 1)
    If TempChar = HardReturn Then
            TempString = TempString & " "
    Else
            TempString = TempString & TempChar
    End If
  Next i
  
  CurrTextStr = TempString
            
  DataTextStr = DataTextStr & CurrTextStr & NewLine

Next

  Dim DataObjectText As New DataObject
  DataObjectText.SetText DataTextStr
  DataObjectText.PutInClipboard
  
End Sub