BBCode Table

[DocAElstein]

Option ExplicitDeclare 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