BBCode Table

How you know it me?

I can have an Avatar? Who knew!? I'd forgotten I even had a login on this forum. Only here 'cos someone said it was broke.

@Pike: I pay YOU. Send me YOUR Bank Details ... PayPal would work :)

Yeah, me too - I came over 'cause Doc steered me over. TMS is rather recognizable. What does BB stand for??

Bulletin Board?

Intrigued ... only 8500 members, and only about 740 with any posts.

Testing Avatar
There you, go, I forgot about my Avatar as well.
My Wife got his up straight away, bless him :rolleyes:

EDIT: Worked.
I tell you what, they have the newest vbullitin softwäre here. hardly ever have any softwäre problems, everything works, and after getting "Hit", they cleared up the virus things in a few days, rather than a few months.. like somewhere else !

Edit:
P.s.
I Welcome you two "newbies" to Excel Fox

@Doc: see post #54. Not gonna be so much to fix, I would guess.

Only thing left to add is the font name ..but different forums have different default and available fonts ..
By adding the font name is get away form the main idea of BBcode generators being a quick and easy way to show your basic worksheet layout in a table

I'm feeling unfulfilled here:)

never mind :)

Good Night, Gentlemen.

there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list

Code:

---

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
    Dim strFontName 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)
            strFontName = BB_Cells.Font.Name
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """][Font=""" & strFontName & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/Font][/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(strColour As String) As String
    objColour = "#" & Right(Right("000000" & Hex(strColour), 6), 2) & Mid(Right("000000" & Hex(strColour), 6), 3, 2) & Left(Right("000000" & Hex(strColour), 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

---