Page 2 of 4 FirstFirst 1234 LastLast
Results 11 to 20 of 40

Thread: test BB Code

  1. #11
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Just some further Testing, as I may have another solution to the problem of codes pasted into a HTML ( or PHP ) Window "Loosing" a carriage return"

    To remind ( me! ) of what i am testing out here: Sometimes it is better to use A HTML ( or PHP ) Code window rather than a BB Code Window to paste in a Forum Post. This can be the case, for example, when a Code itself contains text strings which may have BB Code Tags in. ( The Code tags usually are recognised as just that giving some peculiar results. )

    This Code for example, shown here excactly as I want it, would get messed up in a code Window

    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
    1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
    End Sub

    _................................................. ....

    Pasted in a code Window:

    Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
    End Sub
    You see the BB Code String was evaluated literally as BB Code. - The BB Code string is messed up as I do not want
    _.............................................

    It is found that pasting in a HTML Code window instead can give you this

    HTML Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
    1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
    End Sub
    which is again what I wanted
    _...............................................


    But if you paste directly by copying from the VB Editor ( Ctrl C ) and pasting in the forum Editor in HTML Code tags, then you can get this instead.

    HTML Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"End Sub
    . here the carriage retzurns have "vanished "

    _................................................. ..................................


    _ I noticed and demonstrated that you can get over this sometimes by “doing a stop over “ in between at a a Word Document, that is to say pasting into a Word document first , then re – copying that to the clipboard and pasting that into the Forum Editor.
    http://www.excelfox.com/forum/f17/te...2079/#post9641
    http://www.excelfox.com/forum/f13/bb...2077/#post9645
    _..............................................

    OK that was one “workaround”..... _The other Day I had a similar problem (_.......... with a code i did to overcome the problem of the Forum Editor “eating” spaces of greater than two. )
    http://www.eileenslounge.com/viewtop...art=20#p176255
    _...............)

    _ Some how this “loss of a carriage return crept in when pasted into a Post, ( even though in Word or in a displayed Message Box, the text i wanted to past in seemed OK ).

    _ After a bit of experimenting I tried a modification which was basically this code line

    = Replace((Text), vbCr, vbCr & vbLf, 1, -1) 'In Text~~,~~~replce a vbCr~~~,~~~with a vbCr & vbLf~~~~,~~~~the returned string should start at position 1 of the original ( so whole string returned )(Note: the number is not just where you start replacing- it is also where the returned String may start-so a number greater than 1 will "chop" bits off returning a string of reduced length compared with the original~~~,~~~-1~~indicates replace all occurrences

    Writing a code to do something similar to the text held in the Clipboard appears to do something similar ( Not quite the same .. here what the Message box shows for the “Before” and “after” is different, which was not the case with the modification to the “preventing Forum editor eating spaces more than 2 codes” . Clearly the vbCr and vbLf is a trick one.. )

    _.................

    So Finally
    _ If you wish to use the HTML Code Window rather than the BB Code Window when posting a Code in a Forum Thread.... you

    _ Copy the code from the VB Editor, ( Ctrl C )
    _ Run this code, ( which works on and modifies the text in the Clipboard.

    Code:
    Sub PutInAvbLfInClipboadText() '    "Replcace vbCr with vbCr & vbLf "
    'Get Current Text from Clipboard
    Dim objDat As dataobject
    Set objDat = New dataobject 'Set to a new Instance ( Blue Print ) of dataobject
    'Dim obj As Object
    'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object instance of the Class.
    Let TxtOut = objDat.GetText() 'retrieve the text in this instance of the Class. ( In this case all I have in it is the text typically I think as it is coming from a Ctrl C Copy from the VB Editor )
    Dim originalClipboardText As String: Let originalClipboardText = TxtOut
    Dim TextWithExtravbLF As String
    Let TextWithExtravbLF = Replace(TxtOut, vbCr, vbCr & vbLf, 1, -1)
    'Dump in Clipboard: This second instance of Data Object used to put in Clipboard
    Dim objCliS As dataobject   '**Early Binding.   This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
    Set objCliS = New dataobject '**Must enable Forms Library: In VB Editor do this:  Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in.  Note if you cannot find it try   OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
    ' ( or instead of those two lines  Dim obj As New DataObject ).    or  next two lines are.....Late Binding equivalent'
    'Dim obj As Object'  Late Binding equivalent'   If you declare a variable as Object, you are late binding it.  http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
    'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
    objCliS.SetText TextWithExtravbLF 'Make Data object's text equal to a copy of ORefiginalText
    objCliS.PutInClipboard 'Place current Data object into the Clipboard
    ' Get from clipboard. This a Another Object from class to be sure we have the data in the Clipboard
    MsgBox prompt:="You dumped in Clipboard originally  this " & vbCr & TxtOut & vbCr & "and if you try to get it, you should get" & vbCr & TextWithExtravbLF & ""
    ' End clean up.
    'TheEnd: ' ( Come here always, even on a unpredictable error )
    Set objDat = Nothing '   Good practice...   maybe....
    Set objCliS = Nothing '  .......   http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring.html#post4414065
    End Sub



    _ Paste into the Forum Thread an enclose in HTML Code Tags..This comes out:

    HTML Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
    1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
    End Sub

    PHP Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
    'Line 1
    2 '
    Line 2
    'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
    End Sub 
    Alan
    Last edited by DocAElstein; 03-09-2016 at 09:14 PM.

  2. #12
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Just some further Testing, as I may have another solution to the problem of codes pasted into a HTML ( or PHP ) Window "Loosing" a carriage return"

    To remind ( me! ) of what i am testing out here: Sometimes it is better to use A HTML ( or PHP ) Code window rather than a BB Code Window to paste in a Forum Post. This can be the case, for example, when a Code itself contains text strings which may have BB Code Tags in. ( The Code tags usually are recognised as just that giving some peculiar results. )

    This Code for example, shown here excactly as I want it, would get messed up in a code Window

    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
    1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
    End Sub

    _................................................. ....

    Pasted in a code Window:

    Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in Color"
    End Sub
    You see the BB Code String was evaluated literally as BB Code. - The BB Code string is messed up as I do not want
    _.............................................

    It is found that pasting in a HTML Code window instead can give you this

    HTML Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
    1 'Line 1
    2 'Line 2
    3 'Line 3
    4 Dim strBBCodeTag As String
    5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
    End Sub
    which is again what I wanted
    _...............................................


    But if you paste directly by copying from the VB Editor ( Ctrl C ) and pasting in the forum Editor in HTML Code tags, then you can get this instead.

    HTML Code:
    Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"End Sub
    . here the carriage returns have „vanished!!!!"

    _................................................. ..................................


    _ I noticed and demonstrated that you can get over this sometimes by "doing a stop over " in between at a a Word Document, that is to say pasting into a Word document first , then re

  3. #13
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    IE 11 HTML Tags

    HTML Code:
    '   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    '   http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   No User Form. Run Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
    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
    '
    'Main Code     http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
    Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
         
        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
        'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        'Const csHEADER_BACK As String = "#888888"
        Const csHEADER_BACK As String = "powderblue"
        Const csROW_BACK As String = "#FFFFFF"
        Set BB_Range = Selection
        BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
        'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
        BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]"      ' top left cell
        For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
            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
            BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]"
        For Each BB_Row In BB_Range.Rows 'Row Numbers
            BB_Code = BB_Code & "[tr]"
            'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", 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][/size]"
        'End of main table
        BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
        ClipBoard_SetData (BB_Code)
        Set BB_Range = Nothing
    End Sub
    '
    'Some required functions.    http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
    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)
        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
     
    Private 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
    '
    Private Function ExcelVersion() As String
        Dim temp                  As String
        'On Error Resume Next
    #If Mac Then
        Select Case Val(Application.Version)
            Case 11: temp = "Excel 2004"
            Case 12: temp = "Excel 2008" ' this should NEVER happen!
            Case 14: temp = "Excel 2011"
            Case 15: temp = "vNext"
            Case Else: temp = "Unknown"
        End Select
    #Else
        Select Case Val(Application.Version)
            Case 9: temp = "Excel 2000"
            Case 10: temp = "Excel 2002"
            Case 11: temp = "Excel 2003"
            Case 12: temp = "Excel 2007"
            Case 14: temp = "Excel 2010"
            Case 15: temp = "Excel 2013"
            Case Else: temp = "Unknown"
        End Select
    #End If
        ExcelVersion = temp
    End Function
    '
    '
    Private Function ColLtr(ByVal iCol As Long) As String
    ' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
    ' Good for any positive Long
        If iCol > 0 Then
        ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
        Else
        End If
    End Function

  4. #14
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    IE 11 PHP Tags

    PHP Code:
    '   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    '   
    http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        
    '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   
    No User FormRun Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
    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
    '
    'Main Code     http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
    Sub BB_Table_Clipboard_PikeFoxAlan() '
    http://www.excelfox.com/forum/f13/bbcode-table-2077/    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
         
        
    Dim BB_Row As RangeBB_Cells As RangeBB_Range As Range
        Dim BB_Code 
    As StringstrFontColour As StringstrBackColour As StringstrAlign As StringstrWidth As String
        
    'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        '
    Const csHEADER_BACK As String "#888888"
        
    Const csHEADER_BACK As String "powderblue"
        
    Const csROW_BACK As String "#FFFFFF"
        
    Set BB_Range Selection
        BB_Code 
    "[color=lightgrey]Using " ExcelVersion "[/color]" vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
        '
    BB_Code BB_Code "[tr][td][font=Wingdings]v[/font][/td]" vbNewLine
        BB_Code 
    BB_Code "[tr=bgcolor:" csHEADER_BACK "][th][COLOR=" csHEADER_COLOR "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]"      ' top left cell
        For Each BB_Cells In BB_Range.Rows(1).Cells '
    Column Letters
            strWidth 
    Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth 7.50)
            
    'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
            BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" '
    Column Letter Row
        Next BB_Cells
        BB_Code 
    BB_Code "[/tr]"
        
    For Each BB_Row In BB_Range.Rows 'Row Numbers
            BB_Code = BB_Code & "[tr]"
            '
    BB_Code BB_Code "[td=" """" "bgcolor:#ECF0F0, align:center" """" "][B]" BB_Row.Row "[/B][/td]" vbNewLine
            BB_Code 
    BB_Code "[td=" """" "bgcolor:" csHEADER_BACK ", 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_CellsFalseFalse))
                    
    strBackColour objColour(DisplayedColor(BB_CellsTrueFalse))
                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][/size]"
        'End of main table
        BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" '
    The parent One up the OOP change of the selects range is used to get at the sheet name.
        
    ClipBoard_SetData (BB_Code)
        
    Set BB_Range Nothing
    End Sub
    '
    '
    Some required functions.    http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
    Private Function objColour(strCell As String) As String
        objColour 
    "#" Right(Right("000000" Hex(strCell), 6), 2) & Mid(Right("000000" Hex(strCell), 6), 32) & 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 1011
                    FontAlignment 
    "CENTER"
                
    Case Else
                    
    FontAlignment "RIGHT"
                
    End Select
            End Select
        End With
    End 
    Function
     
    Private Function 
    ClipBoard_SetData(MyString As String)
        
    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
     
    Private Function 
    DisplayedColor(Cell As RangeOptional CellInterior As Boolean True_
        Optional ReturnColorIndex 
    As Long True) As Long
         
        Dim X 
    As LongTest As BooleanCurrentCell As StringdColor   As Variant
        Dim F   
    As StringR  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(00)
        For 
    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 
    xlGreaterEqualTest 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
    '
    Private Function ExcelVersion() As String
        Dim temp                  
    As String
        
    'On Error Resume Next
    #If Mac Then
        Select Case Val(Application.Version)
            Case 11: temp = "Excel 2004"
            Case 12: temp = "Excel 2008" ' 
    this should NEVER happen!
            Case 
    14temp "Excel 2011"
            
    Case 15temp "vNext"
            
    Case Else: temp "Unknown"
        
    End Select
    #Else
        
    Select Case Val(Application.Version)
            Case 
    9temp "Excel 2000"
            
    Case 10temp "Excel 2002"
            
    Case 11temp "Excel 2003"
            
    Case 12temp "Excel 2007"
            
    Case 14temp "Excel 2010"
            
    Case 15temp "Excel 2013"
            
    Case Else: temp "Unknown"
        
    End Select
    #End If
        
    ExcelVersion temp
    End 
    Function
    '
    '
    Private Function ColLtr(ByVal iCol As Long) As String
    ' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
    Good for any positive Long
        
    If iCol 0 Then
        ColLtr 
    ColLtr((iCol 1) \ 26) & Chr(65 + (iCol 1Mod 26)
        Else
        
    End If
    End Function 

  5. #15
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    IE 11 BB Code Tags

    Code:
    '   Convert Excel range to BBCode Table - Page 2
    '   http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   No User Form. Run Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/te...2079/#post9642
    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
    '
    'Main Code     http://www.excelfox.com/forum/f17/te...2079/#post9643
    Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/    Convert Excel range to BBCode Table - Page 2
         
        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
        'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        'Const csHEADER_BACK As String = "#888888"
        Const csHEADER_BACK As String = "powderblue"
        Const csROW_BACK As String = "#FFFFFF"
        Set BB_Range = Selection
        BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "]
    v [COLOR=" & csHEADER_COLOR & "]Row\Col[/COLOR] " & Split(BB_Cells.Address, "$")(1) & "
    [COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR]
    " & BB_Row.Row & " " & BB_Row.Row & " [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
    [/size]" 'End of main table BB_Code = BB_Code & "
    Sheet: " & BB_Range.Parent.Name & "
    " 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name. ClipBoard_SetData (BB_Code) Set BB_Range = Nothing End Sub ' 'Some required functions. http://www.excelfox.com/forum/f17/te...2079/#post9644 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) 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 Private 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 ' Private Function ExcelVersion() As String Dim temp As String 'On Error Resume Next #If Mac Then Select Case Val(Application.Version) Case 11: temp = "Excel 2004" Case 12: temp = "Excel 2008" ' this should NEVER happen! Case 14: temp = "Excel 2011" Case 15: temp = "vNext" Case Else: temp = "Unknown" End Select #Else Select Case Val(Application.Version) Case 9: temp = "Excel 2000" Case 10: temp = "Excel 2002" Case 11: temp = "Excel 2003" Case 12: temp = "Excel 2007" Case 14: temp = "Excel 2010" Case 15: temp = "Excel 2013" Case Else: temp = "Unknown" End Select #End If ExcelVersion = temp End Function ' ' Private Function ColLtr(ByVal iCol As Long) As String ' shg 2012 Alan 2016 VBA Column Letter from Column Number. Explained. ' Good for any positive Long If iCol > 0 Then ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26) Else End If End Function

  6. #16
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Google Chrome
    from
    http://www.ozgrid.com/forum/showthre...613#post763613


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

  7. #17
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Google Chrome from here

    Convert Excel range to BBCode Table - Page 2

    Code:
    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 = "
    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 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

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

  9. #19
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    IE 11


    Code:
    '   Convert Excel range to BBCode Table - Page 2
    '   http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   No User Form. Run Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/te...2079/#post9642
    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
    '
    'Main Code     http://www.excelfox.com/forum/f17/te...2079/#post9643
    Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/    Convert Excel range to BBCode Table - Page 2
         
        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
        'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        'Const csHEADER_BACK As String = "#888888"
        Const csHEADER_BACK As String = "powderblue"
        Const csROW_BACK As String = "#FFFFFF"
        Set BB_Range = Selection
        BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "]
    v [COLOR=" & csHEADER_COLOR & "]Row\Col[/COLOR] " & Split(BB_Cells.Address, "$")(1) & "
    [COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR]
    " & BB_Row.Row & " " & BB_Row.Row & " [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
    [/size]" 'End of main table BB_Code = BB_Code & "
    Sheet: " & BB_Range.Parent.Name & "
    " 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name. ClipBoard_SetData (BB_Code) Set BB_Range = Nothing End Sub ' 'Some required functions. http://www.excelfox.com/forum/f17/te...2079/#post9644 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) 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 Private 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 ' Private Function ExcelVersion() As String Dim temp As String 'On Error Resume Next #If Mac Then Select Case Val(Application.Version) Case 11: temp = "Excel 2004" Case 12: temp = "Excel 2008" ' this should NEVER happen! Case 14: temp = "Excel 2011" Case 15: temp = "vNext" Case Else: temp = "Unknown" End Select #Else Select Case Val(Application.Version) Case 9: temp = "Excel 2000" Case 10: temp = "Excel 2002" Case 11: temp = "Excel 2003" Case 12: temp = "Excel 2007" Case 14: temp = "Excel 2010" Case 15: temp = "Excel 2013" Case Else: temp = "Unknown" End Select #End If ExcelVersion = temp End Function ' ' Private Function ColLtr(ByVal iCol As Long) As String ' shg 2012 Alan 2016 VBA Column Letter from Column Number. Explained. ' Good for any positive Long If iCol > 0 Then ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26) Else End If End Function

  10. #20
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    IE11


    HTML Code:
    '   http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
    '   http://www.excelfox.com/forum/f13/bbcode-table-2077/
    '   '//Original code is written by Rick Rothstein
        '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
    '   No User Form. Run Main Code  Sub BB_Table_Clipboard_PikeFoxAlan()
    Option Explicit
    ' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
    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
    '
    'Main Code     http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
    Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
         
        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
        'Const csHEADER_COLOR As String = """#FFFFFF"""
        Const csHEADER_COLOR As String = "black"
        'Const csHEADER_BACK As String = "#888888"
        Const csHEADER_BACK As String = "powderblue"
        Const csROW_BACK As String = "#FFFFFF"
        Set BB_Range = Selection
        BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
        BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
        'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
        BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]"      ' top left cell
        For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
            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
            BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]"
        For Each BB_Row In BB_Range.Rows 'Row Numbers
            BB_Code = BB_Code & "[tr]"
            'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", 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][/size]"
        'End of main table
        BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
        ClipBoard_SetData (BB_Code)
        Set BB_Range = Nothing
    End Sub
    '
    'Some required functions.    http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
    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)
        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
     
    Private 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
    '
    Private Function ExcelVersion() As String
        Dim temp                  As String
        'On Error Resume Next
    #If Mac Then
        Select Case Val(Application.Version)
            Case 11: temp = "Excel 2004"
            Case 12: temp = "Excel 2008" ' this should NEVER happen!
            Case 14: temp = "Excel 2011"
            Case 15: temp = "vNext"
            Case Else: temp = "Unknown"
        End Select
    #Else
        Select Case Val(Application.Version)
            Case 9: temp = "Excel 2000"
            Case 10: temp = "Excel 2002"
            Case 11: temp = "Excel 2003"
            Case 12: temp = "Excel 2007"
            Case 14: temp = "Excel 2010"
            Case 15: temp = "Excel 2013"
            Case Else: temp = "Unknown"
        End Select
    #End If
        ExcelVersion = temp
    End Function
    '
    '
    Private Function ColLtr(ByVal iCol As Long) As String
    ' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
    ' Good for any positive Long
        If iCol > 0 Then
        ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
        Else
        End If
    End Function

Similar Threads

  1. Replies: 12
    Last Post: 09-22-2023, 03:53 PM
  2. Replies: 5
    Last Post: 06-10-2019, 10:14 PM
  3. HTML Code Test --post8798
    By DocAElstein in forum Test Area
    Replies: 19
    Last Post: 06-17-2018, 03:02 PM
  4. CODE TAG Code Test
    By DocAElstein in forum Test Area
    Replies: 5
    Last Post: 09-16-2015, 05:16 PM

Posting Permissions

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