Attribute VB_Name = "ExportDBToTWiki"
'******************************************************************************
'ExportDBToTWiki: This macro formats the active worksheet to TWiki format and
'                 copies the memory resident worksheet into the clipboard.
'                 This is useful to past the clipboard contents into the TWiki
'                 edit window. For best results use the edit window in TWiki
'                 markup mode.
'
'                 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.
'
'                 Save this file to disk, In excel choose:
'                     Tools -> Macros -> "Visual Basic Editor"
'                     Right click on "VBA Project (Personal.XLS)"
'                     Choose "Import File" and import the ExportToTwiki.bas 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.
'
'                 (Note: If there is no "Microsoft Forms 2.0 Object Library" on
'                 the list, then click on "Browse" and choose the file FM20.dll,
'                 and it should appear. Enabling the Analysis ToolPak add-in
'                 will also make this reference available.)
'
'                 Because you added this macro to your personal.XLS, it will
'                 be available for all the spreadsheets you open.
'
'
' Note: I guess this macro at one time saved the memory formated text to a file
'       This capability its no longer available. If anyone needs it, let me
'       know and I will added it (gdias@kits-llc.com, gdias@csc.com)
'
' Addon home page:
' http://twiki.org/cgi-bin/view/Plugins/ExcelExportTwikiTableAddOn
'******************************************************************************
' Revisions:
'
' Date        Ver  Aurthor         Remarks
' 11-Aug-2003      JohnRouillard   - Initial version
'
' 14-Aug-2003 1.1  SteveRJones     - added ALT-ENTER (hard carriage return)
'                                    removal code 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.
'                                  - changed GetSaveAsFilename so that the save
'                                    dir was whever you saved to last - just in
'                                    case you have lots of tabbed sheets to
'                                    convert!
'
' 03 Nov 2004   1.2 ElliotSchwartz - added export of bold cells with asterisks
'
' 10 Jul 2005   1.3 JosMaccabiani  - added export of italic cells with
'                                    underscores
'
' 06 Jan 2006   1.4 UnknownUser    - direct export to clipboard; added support
'                                    for horizontally joined cells
'
' 13 Jul 2006   1.5 ChrisWerry     - center and right align fromatted cells,
'                                    right align numeric fields and use
'                                    CurrCell.Text instead of CurrCell.Value to
'                                    retain numeric formatting.
'
' 04 Nov 2006   1.6 RockyLin       - added hyperlink support
'
' 05 Jun 2007                      - MS Excel 2003 fixes:
'                                    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
'
' 05 May 2008   1.7 ChrisWerry     - added more formatting support
'
' 20 Aug 2008   1.8 KingWei        - For merge cells,use of multi-span for rows
'
' 20 Nov 2009   1.9 GeorgeDias     - Replaced loops utilized to detect and
'                                    replace hard-returns and occurrences of
'                                    pipe with the native Replace function.
'                                  - Added %NOP% to WikiWords within the text
'                                    to prevent automatically creation of
'                                    hyperlinks.
'                                  - Added <literal></literal> to color text.
'                                  - Added TWiki cell color format.
'                                  - Added Table Plugin settings capabilities
'
'******************************************************************************
Option Explicit

Const LIST_SEP = "|"
Const BOLD_CHAR = "*"
Const ALIGN_CHAR = "  "
Const ITALIC_CHAR = "_"
Const END_COLOR = "%ENDCOLOR%"
Const STRIKE = "<strike>"
Const END_STRIKE = "</strike>"
Const LITERAL = "<literal>"
Const END_LITERAL = "</literal>"
Const PIPE_CHAR = "&#124;"
Const vbSpace = " "
Const TWikiNOP = "%NOP%"
Const URLCharLeft = "["
Const URLCharRight = "]"
'******************************************************************************
'                     M     M      A      I   N    N                          *
'                     M M M M     A A     I   N N  N                          *
'                     M  M  M    AAAAA    I   N  N N                          *
'                     M     M   A     A   I   N    N                          *
' Macro Entry Point                                                           *
'******************************************************************************
Sub ExportDBToTWiki()
    
    Dim SrcRg As Range
    Dim CurrRow As Range
    Dim CurrCell As Range
    Dim CurrTextStr As String
    Dim TextWithURL As String
    Dim FontChar As String
    Dim DataTextStr As String
    Dim TempString As String
    Dim xColor As String
    Dim strdatabg As String
    Dim strColWidths As String
    Dim blnNewRow As Boolean
    
    Set SrcRg = ActiveSheet.UsedRange
    For Each CurrRow In SrcRg.Rows
        blnNewRow = True
        CurrTextStr = LIST_SEP
    
        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 & LIST_SEP
                ' For merge cells,use of multi-span for rows
            ElseIf (CurrCell.MergeCells And (CurrCell.MergeArea.Column = CurrCell.Column) And (CurrCell.Text = "")) Then
                CurrTextStr = CurrTextStr & "^" & LIST_SEP
            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 & " " & LIST_SEP
            Else
                If (CurrCell.Font.Bold) Then
                    FontChar = BOLD_CHAR
                ElseIf (CurrCell.Font.Italic) Then
                    FontChar = ITALIC_CHAR
                Else
                    FontChar = ""
                End If
          
                ' Look for occurrances of pipe (used as TWiki table separator)
                ' in the cell data, replace with ASCII pipe char
                TempString = Replace(PatchPascalCase(CurrCell.Text), LIST_SEP, PIPE_CHAR)
                
                ' 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 = LITERAL & "<font color=#" & Right(xColor, 2) & _
                               Mid(xColor, 3, 2) & Left(xColor, 2) & ">" & _
                               TempString & END_COLOR & END_LITERAL
                End If
                
                ' Set Table row background color
                ' Sometimes the first column of a row has a special color
                ' (aesthetics) if this is the case use the appropriate If
                ' statement to retrieve background row color base on specific
                ' column. If row color is to be retrieved from the first column
                ' use this
                '     If CurrCell.Row > 1 And blnNewRow Then
                '
                ' If row color is to be retrieved from the second column use this
                If CurrCell.Row > 1 And CurrCell.Column = 2 And blnNewRow Then
                    xColor = Right("000000" & Hex(CurrCell.Interior.Color), 6)
                    ' Need to reverse Hex color value
                    xColor = Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2)
                    strdatabg = IIf(strdatabg = "", strdatabg & "#" & xColor, strdatabg & "," & "#" & xColor)
                    blnNewRow = False
                End If
                
                ' Copy strikethrough formatting
                If (CurrCell.Font.Strikethrough) Then
                    TempString = STRIKE & TempString & END_STRIKE
                End If
        
                ' Add URL codes
                If (CurrCell.Hyperlinks.Count = 1) Then
                    TempString = URLCharLeft & URLCharLeft & CurrCell.Hyperlinks(1).Address & URLCharRight & URLCharLeft & TempString & URLCharRight & URLCharRight
                End If
                
                ' Set Horizontal Alignment
                If CurrCell.HorizontalAlignment = xlCenter Then
                    ' Center column and add font
                    CurrTextStr = CurrTextStr & ALIGN_CHAR & FontChar & TempString & FontChar & ALIGN_CHAR & LIST_SEP
                ElseIf CurrCell.HorizontalAlignment = xlRight Or IsNumeric(CurrCell.Value) Then
                    ' Right align column and add font
                    CurrTextStr = CurrTextStr & ALIGN_CHAR & FontChar & TempString & FontChar & LIST_SEP
                Else
                    CurrTextStr = CurrTextStr & FontChar & TempString & FontChar & LIST_SEP
                End If
            End If
        Next
        
        ' Look for occurrances of hard-returns in the cell data, replace with a space
        ' replace all carriage return characters
        CurrTextStr = Replace(CurrTextStr, vbCr, " ")
        ' replace all linefeed characters
        CurrTextStr = Replace(CurrTextStr, vbLf, " ")
      
        ' append a combination linefeed carriage return (NewLine)
        DataTextStr = DataTextStr & CurrTextStr & vbCrLf
    
    Next
    
    ' Get the columnwidths based on cell widths
    strColWidths = GetColWidth(SrcRg)
    ' Set the Table format
    DataTextStr = "%TABLE{sort=""on"" tableborder=""0"" cellpadding=""0"" cellspacing=""3"" " & _
                  "databg=""" & strdatabg & """ tablewidth=""100%"" columnwidths=""" & _
                  strColWidths & """}%" & vbCrLf & DataTextStr
    Dim DataObjectText As New DataObject
    DataObjectText.SetText DataTextStr
    DataObjectText.PutInClipboard
  
End Sub
'******************************************************************************
'PatchPascalCase: This function detects in a give string is in PascalCase and
'                 adds the WikiWords %NOP% to the text preventing automatic
'                 creation of hyperlinks.
'
'******************************************************************************
Private Function PatchPascalCase(str As String)
    
    Dim i As Integer
    Dim j As Integer
    Dim strPatched As String
    Dim strTmp As String
    Dim arrSplit() As String
    Dim blnFirst As Boolean

    arrSplit = Split(str, vbSpace)
    For i = 0 To UBound(arrSplit)
        ' Don't analys two character words
        If Len(arrSplit(i)) > 2 Then
            For j = 1 To Len(arrSplit(i))
                If IsUpper(Mid(arrSplit(i), j, 1)) Then
                    If blnFirst Then
                        ' If CamelCase word is inside prentices, place the %NOP%
                        ' WikiWords accordantly
                        If InStr(1, "(", Left(arrSplit(i), 1), vbTextCompare) Then
                            strTmp = strTmp & "(" & TWikiNOP & Right(arrSplit(i), _
                                     Len(arrSplit(i)) - 1)
                        Else
                            strTmp = strTmp & TWikiNOP & arrSplit(i)
                        End If
                        Exit For
                    Else
                        blnFirst = True
                    End If
                End If
                
            Next
            
            If StrComp(strTmp, "", vbBinaryCompare) = 0 Then
                strPatched = strPatched & vbSpace & arrSplit(i)
            Else
                strPatched = strPatched & vbSpace & strTmp
            End If
            
            strTmp = ""
            blnFirst = False
        Else
            strPatched = strPatched & vbSpace & arrSplit(i)
        End If
    Next
    
    PatchPascalCase = Trim(strPatched)

End Function
'******************************************************************************
'IsUpper: This function detects in given character is in upper case.
'         Note that it returns false if value passed in is not a valid char and
'         it returns True if value passed in numeric (number)
'
'******************************************************************************
Private Function IsUpper(strValue As String) As Boolean
    
    Select Case Asc(strValue)
        Case 97 To 122
            ' This is a lower-case letter.
            IsUpper = False
        Case 65 To 90
            ' This is an upper-case letter.
            IsUpper = True
        Case 48 To 57
            ' This is a number (0-9)
            IsUpper = True
        Case Else
            ' This is not a letter.
            IsUpper = False
    End Select
    
End Function

'******************************************************************************
'GetColWidth: This function returns the concatenated column widths for all
'             columns contained within given range in TWiki Table Plugin
'             percent format.
'
'******************************************************************************
Private Function GetColWidth(thisRange As Range) As String

    Dim i As Integer
    Dim intCols As Integer
    Dim intArrColWidth() As Integer
    Dim lngTotalWidth As Long
    Dim strPercentWidths As String
    
    intCols = GetCharVal(Mid(thisRange.Address, InStr(1, thisRange.Address, ":", vbTextCompare) + 2, 1))
    
    For i = 0 To intCols - 1
        ReDim Preserve intArrColWidth(i)
        intArrColWidth(i) = thisRange.Cells(1, i + 1).Width
        lngTotalWidth = lngTotalWidth + intArrColWidth(i)
    Next
    
    For i = 0 To UBound(intArrColWidth)
        strPercentWidths = strPercentWidths & Int(((intArrColWidth(i) / lngTotalWidth) * 100)) & "%,"
    Next
    
    GetColWidth = Left(strPercentWidths, Len(strPercentWidths) - 1)
End Function
'******************************************************************************
'GetCharVal: This function returns the integer value of a given character
'            related to its alphabet position.
'
'******************************************************************************
Private Function GetCharVal(strChar) As Integer
    
    Dim strAlphabet As String
    strAlphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    GetCharVal = InStr(1, strAlphabet, strChar, vbTextCompare)

End Function