Sadly , I am a computer novice, and do not really understand.
Just post the workbook with the code and I will copy it to see what I get .. other wise no one can help
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
Sadly , I am a computer novice, and do not really understand.
Just post the workbook with the code and I will copy it to see what I get .. other wise no one can help
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
Last edited by DocAElstein; 10-02-2023 at 12:57 PM.
Any Code will do that has strings in it containing BB Code Tag Strings in it
In the Workbook I gave you before you could pick any codes...
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
I do not really need any help. I was just pointing out problems and solutions.
I do not need help.
I have been giving help.
As long as you use HTML or PHP Code Tags for such codes then there is usually no problem. ( Only very occaisionally you get the loss of carriage return problem, and I gave solutions for that too )
For example..
Codes from Module PikeCode
In Code Tags I ( and most people who asked me for help ) get:
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 = "" ClipBoard_SetData (BB_Code) Set BB_Range = Nothing End Sub Private 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 Private 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 Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this 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
v " & Split(BB_Cells.Address, "$")(1) & " " & BB_Row.Row & " [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
Last edited by DocAElstein; 05-02-2016 at 03:01 PM.
In HTML Tags initially
HTML 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 LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private 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 = NothingEnd Sub Private 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 Private 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 WithEnd Function Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this 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 IfEnd Function
In HTML Tags after running my code from Post #10 to solve the missing carriage return problem that occaisonally occurs
HTML 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 Private 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 Private 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 Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this 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
in php code tags initially
PHP 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 LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private 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 = NothingEnd Sub
Private 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
Private 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 WithEnd Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this 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 IfEnd Function
in php tags after running my code from post #10
PHP 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
Private 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
Private 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
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
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
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 = "" ClipBoard_SetData (BB_Code) Set BB_Range = Nothing End Sub
v " & Split(BB_Cells.Address, "$")(1) & " " & BB_Row.Row & " [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
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
After [code] I added [noparse] and it stops the complier reading the code and making a table/scroll within the vba.
Post #27 with missing noparse tags and compiled scroll in window .then post #28 with noparse tags just syntax.
I have gone back and changed the post #1 from php to code tags .. that was an oversight using php
Last edited by pike; 05-02-2016 at 03:25 PM.
Last edited by DocAElstein; 05-02-2016 at 03:43 PM.
Bookmarks