Convert Excel range to BBCode Table

Option Explicit
Sub test()
    BB_Table Range("D1:F20"), True
End Sub




Sub BB_Table(BB_Range As Range, Optional BBHeader As Boolean = True)


    Dim BB_Row As Range
    Dim BB_Cells As Range


    Debug.Print "[table=" & """" & "class: grid" & """" & "]"
    If BBHeader Then
        Debug.Print "[tr][td][/td]"
        For Each BB_Cells In BB_Range.Rows(1).Cells
            Debug.Print "[td]" & Chr$(BB_Cells.Column + 64) & "[/td]"
        Next BB_Cells
        Debug.Print "[/tr]"
    End If
    For Each BB_Row In BB_Range.Rows
        Debug.Print "[tr]"
        If BBHeader Then
            Debug.Print "[td]" & BB_Row.Row & "[/td]"
        End If
        For Each BB_Cells In BB_Row.Cells
            Debug.Print "[td]" & BB_Cells.Text & "[/td]"
        Next BB_Cells
        Debug.Print "[/tr]"
    Next BB_Row
    Debug.Print "[/table]"
End Sub

Sub BB_Table(BB_Range As Range, Optional BB_Header As Boolean = True)


    Dim BB_Row As Range
    Dim BB_Cells As Range


   Debug.Print "[table=" & """" & "class: grid" & """" & "]"
    If BB_Header Then Debug.Print "[tr][td][/td]"
        For Each BB_Cells In BB_Range.Rows(1).Cells
            Debug.Print "[td]" & Chr$(BB_Cells.Column + 64) & "[/td]"
        Next BB_Cells
        Debug.Print "[/tr]"
   
    For Each BB_Row In BB_Range.Rows
        Debug.Print "[tr]"
        If BB_Header Then Debug.Print "[td]" & BB_Row.Row & "[/td]"
        For Each BB_Cells In BB_Row.Cells
            Debug.Print "[th]" & BB_Cells.Text & "[/th]"
        Next BB_Cells
        Debug.Print "[/tr]"
    Next BB_Row
    Debug.Print "[/table]"
End Sub

Sub BB_Table(BB_Range As Range, Optional BB_Header As Boolean = True)


    Dim BB_Row As Range
    Dim BB_Cells As Range


    Debug.Print "[table=" & """" & "class: grid" & """" & "]"
    If BB_Header Then Debug.Print "[tr][td][/td]"
        For Each BB_Cells In BB_Range.Rows(1).Cells
          '  Debug.Print "[td]" & Chr$(BB_Cells.Column + 64) & "[/td]"
         
       Debug.Print "[td=" & """" & "bgcolor:#8E5A2E, align:center" & """" & "][color=#FFFFFF][b]" & Chr$(BB_Cells.Column + 64) & "[/b][/color][/td]"
        Next BB_Cells
        Debug.Print "[/tr]"
   
    For Each BB_Row In BB_Range.Rows
        Debug.Print "[tr]"
       ' If BB_Header Then Debug.Print "[td]" & BB_Row.Row & "[/td]"
        If BB_Header Then Debug.Print "[td=" & """" & "bgcolor:#8E5A2E, align:center" & """" & "][color=#FFFFFF][b]" & BB_Row.Row & "[/b][/color][/td]"
        For Each BB_Cells In BB_Row.Cells
            Debug.Print "[th]" & BB_Cells.Text & "[/th]"
        Next BB_Cells
        Debug.Print "[/tr]"
    Next BB_Row
    Debug.Print "[/table]"
End Sub

Sub BB_Table(BB_Range As Range, Optional BB_Header As Boolean = True)


    Dim BB_Row As Range
    Dim BB_Cells As Range


    Debug.Print "[table=" & """" & "class:grid_thin" & """" & "]"
      If BB_Header Then Debug.Print "[tr][td][/td]"
         For Each BB_Cells In BB_Range.Rows(1).Cells
            Debug.Print "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & Chr$(BB_Cells.Column + 64) & "[/B][/td]"
         Next BB_Cells
       Debug.Print "[/tr]"
   
    For Each BB_Row In BB_Range.Rows
        Debug.Print "[tr]"
         If BB_Header Then Debug.Print "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]"
           For Each BB_Cells In BB_Row.Cells
              Debug.Print "[td]" & BB_Cells.Text & "[/td]"
           Next BB_Cells
        Debug.Print "[/tr]"
    Next BB_Row
     Debug.Print "[/table]"
End Sub

Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096


Sub BB_Table_Clipboard()
    Dim BB_Row As Range
    Dim BB_Cells As Range
    Dim BB_Range As Range
    Dim BB_Array As String


    Set BB_Range = Selection
    BB_Array = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
    BB_Array = BB_Array & "[tr][td][/td]" & vbNewLine
    For Each BB_Cells In BB_Range.Rows(1).Cells
        BB_Array = BB_Array & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & Chr$(BB_Cells.Column + 64) & "[/B][/td]" & vbNewLine
    Next BB_Cells
    BB_Array = BB_Array & "[/tr]"
    For Each BB_Row In BB_Range.Rows
        BB_Array = BB_Array & "[tr]"
        BB_Array = BB_Array & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
        For Each BB_Cells In BB_Row.Cells
            BB_Array = BB_Array & "[td]" & BB_Cells.Text & "[/td]" & vbNewLine
        Next BB_Cells
        BB_Array = BB_Array & "[/tr]" & vbNewLine
    Next BB_Row
    BB_Array = BB_Array & "[/table]"
    ClipBoard_SetData (BB_Array)
    Set BB_Cells = Nothing
End Sub


Function ClipBoard_SetData(MyString As String)
    Dim hGlobalMemory As Long, lpGlobalMemory As Long
    Dim hClipMemory As Long, X As Long


    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Could not unlock memory location. Copy aborted."
        GoTo OutOfHere2
    End If
    If OpenClipboard(0&) = 0 Then
        MsgBox "Could not open the Clipboard. Copy aborted."
        Exit Function
    End If
    X = EmptyClipboard()
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "Could not close Clipboard."
    End If
End Function

Sub BB_Table_Clipboard()
    Dim BB_Row As Range
    Dim BB_Cells As Range
    Dim BB_Range As Range
    Dim BB_Array As String


    Set BB_Range = Selection
    BB_Array = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
    BB_Array = BB_Array & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
    For Each BB_Cells In BB_Range.Rows(1).Cells
       BB_Array = BB_Array & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
    Next BB_Cells
    BB_Array = BB_Array & "[/tr]"
    For Each BB_Row In BB_Range.Rows
        BB_Array = BB_Array & "[tr]"
        BB_Array = BB_Array & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
        For Each BB_Cells In BB_Row.Cells
            BB_Array = BB_Array & "[td]" & BB_Cells.Text & "[/td]" & vbNewLine
        Next BB_Cells
        BB_Array = BB_Array & "[/tr]" & vbNewLine
    Next BB_Row
    BB_Array = BB_Array & "[/table]"
    ClipBoard_SetData (BB_Array)
    Set BB_Cells = Nothing
End Sub

Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096


Sub BB_Table_Clipboard()
    Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
    Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String


    Set BB_Range = Selection
    BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
    BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
    For Each BB_Cells In BB_Range.Rows(1).Cells
        strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
    Next BB_Cells
    BB_Code = BB_Code & "[/tr]"
    For Each BB_Row In BB_Range.Rows
        BB_Code = BB_Code & "[tr]"
        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
        For Each BB_Cells In BB_Row.Cells
            strFontColour = objColour(BB_Cells.Font.Color)
            strBackColour = objColour(BB_Cells.Interior.Color)
            strAlign = FontAlignment(BB_Cells)
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]" & vbNewLine
    Next BB_Row
    BB_Code = BB_Code & "[/table]"
    ClipBoard_SetData (BB_Code)
    Set BB_Range = Nothing
End Sub


Function objColour(strCell As String)as string
    objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function


Function FontAlignment(ByVal objCell As Object) As String
    With objCell
        Select Case .HorizontalAlignment
        Case xlLeft
            FontAlignment = "LEFT"
        Case xlRight
            FontAlignment = "RIGHT"
        Case xlCenter
            FontAlignment = "CENTER"
        Case Else
            Select Case VarType(.Value2)
            Case 8
                FontAlignment = "LEFT"
            Case 10, 11
                FontAlignment = "CENTER"
            Case Else
                FontAlignment = "RIGHT"
            End Select
        End Select
    End With
End Function


Function ClipBoard_SetData(MyString As String)
    Dim hGlobalMemory As Long, lpGlobalMemory As Long
    Dim hClipMemory As Long, X As Long


    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Could not unlock memory location. Copy aborted."
        GoTo OutOfHere2
    End If
    If OpenClipboard(0&) = 0 Then
        MsgBox "Could not open the Clipboard. Copy aborted."
        Exit Function
    End If
    X = EmptyClipboard()
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "Could not close Clipboard."
    End If
End Function

[table="class:thin_grid"]
[tr][td][font=Wingdings]v[/font][/td]
[td="bgcolor:#ECF0F0, align:center, width:102"][B]A[/B][/td]
[td="bgcolor:#ECF0F0, align:center, width:126"][B]B[/B][/td]
[td="bgcolor:#ECF0F0, align:center, width:77"][B]C[/B][/td]
[/tr][tr][td="bgcolor:#ECF0F0, align:center"][B]1[/B][/td]
[td="bgcolor:#FFFFFF, align:CENTER"][COLOR="#000000"]order[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:CENTER"][COLOR="#000000"]product[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:CENTER"][COLOR="#000000"]qty[/COLOR][/td]
[/tr]
[tr][td="bgcolor:#ECF0F0, align:center"][B]2[/B][/td]
[td="bgcolor:#FFFFFF, align:LEFT"][COLOR="#000000"]1001[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:CENTER"][COLOR="#000000"]orange[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:RIGHT"][COLOR="#2F75B5"]3[/COLOR][/td]
[/tr]
[tr][td="bgcolor:#ECF0F0, align:center"][B]3[/B][/td]
[td="bgcolor:#FFFFFF, align:RIGHT"][COLOR="#F4B084"]1002[/COLOR][/td]
[td="bgcolor:#FF0000, align:CENTER"][COLOR="#000000"]berry red[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:LEFT"][COLOR="#000000"]1[/COLOR][/td]
[/tr]
[tr][td="bgcolor:#ECF0F0, align:center"][B]4[/B][/td]
[td="bgcolor:#FFFFFF, align:CENTER"][COLOR="#000000"]1002[/COLOR][/td]
[td="bgcolor:#FFFF00, align:RIGHT"][COLOR="#FF0000"]berry red[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:LEFT"][COLOR="#000000"]1[/COLOR][/td]
[/tr]
[tr][td="bgcolor:#ECF0F0, align:center"][B]8[/B][/td]
[td="bgcolor:#FFFFFF, align:RIGHT"][COLOR="#000000"]1004[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:RIGHT"][COLOR="#FF0000"]berry red[/COLOR][/td]
[td="bgcolor:#FFFFFF, align:RIGHT"][COLOR="#000000"]1[/COLOR][/td]
[/tr]
[/table]

Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
 
Sub BB_Table_Clipboard()
    
    Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
    Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
     
    Set BB_Range = Selection
    BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
    BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
    For Each BB_Cells In BB_Range.Rows(1).Cells
        strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
    Next BB_Cells
    BB_Code = BB_Code & "[/tr]"
    For Each BB_Row In BB_Range.Rows
        BB_Code = BB_Code & "[tr]"
        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
        For Each BB_Cells In BB_Row.Cells
            If BB_Cells.FormatConditions.Count Then
                strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
                strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
            Else
                strFontColour = objColour(BB_Cells.Font.Color)
                strBackColour = objColour(BB_Cells.Interior.Color)
            End If
            strAlign = FontAlignment(BB_Cells)
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]" & vbNewLine
    Next BB_Row
    BB_Code = BB_Code & "[/table]"
    ClipBoard_SetData (BB_Code)
    Set BB_Range = Nothing
End Sub
 
Function objColour(strCell As String) As String
    objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
 
Function FontAlignment(ByVal objCell As Object) As String
    With objCell
        Select Case .HorizontalAlignment
        Case xlLeft
            FontAlignment = "LEFT"
        Case xlRight
            FontAlignment = "RIGHT"
        Case xlCenter
            FontAlignment = "CENTER"
        Case Else
            Select Case VarType(.Value2)
            Case 8
                FontAlignment = "LEFT"
            Case 10, 11
                FontAlignment = "CENTER"
            Case Else
                FontAlignment = "RIGHT"
            End Select
        End Select
    End With
End Function
 
Function ClipBoard_SetData(MyString As String)
    Dim hGlobalMemory As Long, lpGlobalMemory As Long
    Dim hClipMemory As Long, X As Long
     
    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Could not unlock memory location. Copy aborted."
        GoTo OutOfHere2
    End If
    If OpenClipboard(0&) = 0 Then
        MsgBox "Could not open the Clipboard. Copy aborted."
        Exit Function
    End If
    X = EmptyClipboard()
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "Could not close Clipboard."
    End If
End Function


Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
                        Optional ReturnColorIndex As Long = True) As Long
  
    Dim X As Long, Test As Boolean, CurrentCell As String, dColor   As Variant
    Dim F   As String, R  As Range
    
    '//Original code is written by Rick Rothstein
    '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    
    If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
    CurrentCell = ActiveCell.Address(0, 0)
    For X = 1 To Cell.FormatConditions.Count
        With Cell.FormatConditions(X)
            If .Type = xlCellValue Then
                Select Case .Operator
                    Case xlBetween:      Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
                    Case xlNotBetween:   Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
                    Case xlEqual:        Test = Evaluate(.Formula1) = Cell.Value
                    Case xlNotEqual:     Test = Evaluate(.Formula1) <> Cell.Value
                    Case xlGreater:      Test = Cell.Value > Evaluate(.Formula1)
                    Case xlLess:         Test = Cell.Value < Evaluate(.Formula1)
                    Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
                    Case xlLessEqual:    Test = Cell.Value <= Evaluate(.Formula1)
                End Select
            ElseIf .Type = xlExpression Then
                Application.ScreenUpdating = False
                'Cell.Select
                F = Replace(.Formula1, "$", vbNullString)
                F = Replace(F, CurrentCell, Cell.Address(0, 0))
                'Test = Evaluate(.Formula1)
                Test = Evaluate(F)
                'Range(CurrentCell).Select
                Application.ScreenUpdating = True
            End If
            If Test Then
                If CellInterior Then
                    dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
                    If IsNull(dColor) Then
                        dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
                    End If
                Else
                    dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
                    If IsNull(dColor) Then
                        dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
                    End If
                End If
                DisplayedColor = dColor
                Exit Function
            End If
        End With
    Next
    If CellInterior Then
        dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
    Else
        dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
    End If
    DisplayedColor = dColor


End Function