Page 3 of 7 FirstFirst 12345 ... LastLast
Results 21 to 30 of 62

Thread: BBCode Table

  1. #21
    Junior Member pike's Avatar
    Join Date
    Dec 2011
    Posts
    27
    Rep Power
    0
    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.

  2. #22
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Quote Originally Posted by pike View Post
    Just post the workbook with the code and I will copy it to see what I get .. other wise no one can help
    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 = "
    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]
    " 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
    Last edited by DocAElstein; 05-02-2016 at 03:01 PM.

  3. #23
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    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

  4. #24
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    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

  5. #25
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    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 LonglpGlobalMemory As Long    Dim hClipMemory As LongAs Long
        hGlobalMemory 
    GlobalAlloc(GHNDLen(MyString) + 1)    lpGlobalMemory GlobalLock(hGlobalMemory)    lpGlobalMemory lstrcpy(lpGlobalMemoryMyString)    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    EmptyClipboard()    hClipMemory SetClipboardData(CF_TEXThGlobalMemory)OutOfHere2:    If CloseClipboard() = 0 Then        MsgBox "Could not close Clipboard."    End IfEnd Function 

  6. #26
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    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 LongByVal 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 AnyByVal lpString2 As Any) As Long
    Declare Function SetClipboardData Lib "User32" (ByVal wFormat As LongByVal 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 LonglpGlobalMemory As Long
        Dim hClipMemory 
    As LongAs Long


        hGlobalMemory 
    GlobalAlloc(GHNDLen(MyString) + 1)
        
    lpGlobalMemory GlobalLock(hGlobalMemory)
        
    lpGlobalMemory lstrcpy(lpGlobalMemoryMyString)
        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
        
    EmptyClipboard()
        
    hClipMemory SetClipboardData(CF_TEXThGlobalMemory)
    OutOfHere2:
        If 
    CloseClipboard() = 0 Then
            MsgBox 
    "Could not close Clipboard."
        
    End If
    End Function 

  7. #27
    Junior Member pike's Avatar
    Join Date
    Dec 2011
    Posts
    27
    Rep Power
    0
    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 = "
    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]
    " ClipBoard_SetData (BB_Code) Set BB_Range = Nothing End Sub

  8. #28
    Junior Member pike's Avatar
    Join Date
    Dec 2011
    Posts
    27
    Rep Power
    0
    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

  9. #29
    Junior Member pike's Avatar
    Join Date
    Dec 2011
    Posts
    27
    Rep Power
    0
    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.

  10. #30
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Quote Originally Posted by pike View Post
    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........
    |code||noparse|BB Code Tag Table Generator VBA Code Here|/noparse||/code| ( just using | for square brackets as demo here of what to do )

    Nice alternative solution. Thanks


    ( So how did it work for you before without the extra noparse bits in a normal code window ??)
    Last edited by DocAElstein; 05-02-2016 at 03:43 PM.

Similar Threads

  1. test bbcode
    By pike in forum Test Area
    Replies: 3
    Last Post: 05-16-2016, 03:58 AM
  2. Excluding Records of one Table from the Other Table
    By Transformer in forum Tips, Tricks & Downloads (No Questions)
    Replies: 0
    Last Post: 05-17-2013, 12:32 AM

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •