Code:Option Explicit ' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613 'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html 'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370 'Copy the syntax in the "VB:" window below to a standard Module 'Select the range in the worksheet to be converted 'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode. 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 Private Const GHND = &H42 Private Const CF_TEXT = 1 Private Const MAXSIZE = 4096 Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370 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
Bookmarks