Page 1 of 4 123 ... LastLast
Results 1 to 10 of 40

Thread: test BB Code

Hybrid View

Previous Post Previous Post   Next Post Next Post
  1. #1
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10

    test BB Code. Forum Tools. Forum Spreadsheet Screenshot Generator

    Test New Pike / Fox / Rick Code


    Using Excel 2007
    Row\Col
    J
    K
    L
    5 Test ying "PikeFoxRick"
    6 Note does not
    7 have The XL2007
    8 Cell Text Color
    9 problem that some
    10 similar codes have
    Sheet: Molly
    Last edited by DocAElstein; 03-16-2018 at 04:11 PM.

  2. #2
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    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/Option ExplicitDeclare 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_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/         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 & "[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]"    '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 = 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)    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 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 14temp "Excel 2011"        Case 15temp "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 = tempEnd Function''Private Function ColLtr(ByVal iCol As Long) As String' shg 2012' Good for any positive Long    If iCol > 0 Then    ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)    Else    End IfEnd Function 


    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    https://www.eileenslounge.com/viewtopic.php?f=44&t=40455&p=313035#p313035
    https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312889#p312889
    https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312886#p312886
    https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312752#p312752
    https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312734#p312734
    https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312727#p312727
    https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724
    https://www.eileenslounge.com/viewtopic.php?f=44&t=40374&p=312535#p312535
    https://www.eileenslounge.com/viewtopic.php?p=312533#p312533
    https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499
    https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9xpn-GDkL3o
    https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg
    https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg
    https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B
    https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm
    https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
    Last edited by DocAElstein; 03-01-2024 at 02:50 PM.

  3. #3
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    So I think as of Jan 2015, I have a collection of BB Code Generating Macros in
    “MollyBBCodes.xlsm”
    And I think I have tidied the File up a bit, such that all these codes work independently.. ( But I may have missed a shared function or two!! )

    File:
    https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
    http://www.excelforum.com/attachment...lybbcodes.xlsm
    http://www.excelforum.com/developmen...ml#post4293889
    http://www.excelfox.com/forum/f17/te...2079/#post9635



    Sub ShowRangeToBBCFormRoryAForumTools()
    Excel 2007
    Row\Col
    G
    H
    5
    Test Test
    Sheet: Molly
    Excel 2007
    Row\Col
    G
    H
    5
    Test =G5
    Sheet: Molly


    Sub ShowRangeToBBCFormJune()
    Using Excel 2007
    Row\Col
    G
    H
    5
    Test Test
    Molly
    Using Excel 2007
    Row\Col
    G
    H
    5
    Test =G5
    Molly

    Sub ShowRangeToBBCFormSkyBlue()
    Using Excel 2007
    -
    G
    H
    5
    Test Test
    Molly
    Using Excel 2007
    -
    G
    H
    5
    Test =G5
    Molly

    Sub CopyRngToHTMLJBeaucaireBigMolly()
    BigMolly
    Row\Col
    G
    H
    5
    Test
    Test


    Sub CopyRngToBBCodeExcelForumLongThread()

    G
    H
    5
    Test
    Test



    Sub BB_Table_Clipboard_PikeAlan()
    Using Excel 2007
    Row\Col
    H
    5 Test
    Sheet: Molly

    Sub BB_Table_Clipboard_PikeFoxAlan()
    Using Excel 2007
    Row\Col
    J
    K
    L
    5 Test ying "PikeFoxRick"
    6 Note does not
    7 have The XL2007
    8 Cell Text Color
    9 problem that some
    10 similar codes have
    Sheet: Molly


    Alan
    Last edited by DocAElstein; 01-20-2016 at 08:03 PM.

  4. #4
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Using Excel 2007
    Row\Col
    D
    E
    F
    G
    H
    I
    J
    K
    63 87 24 62 97 12 47 33 77
    64 48 90 44 10 91 51 18 65
    65 65 61 69 96 84 54 13 92
    66 72 94 96 83 71 47 22 25
    67 27 94 74 21 13 31 27 76
    68 25 46 52 14 95 32 90 92
    69 54 29 53 17 45 20 10 81
    70 84 11 74 28 33 45 52 10
    71 76 55 56 91 88 76 49 26
    72 10 69 20 51 11 74 37 73
    73 46 25 94 94 53 68 57 19
    74 90 93 89 41 26 11 25 99
    75 94 61 24 29 54 85 81 20
    Sheet: Molly


    Here a bit of my code:


    PHP Code:
    Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/         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 "[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 
    _................................

    Here a bit of Admin's code from Post #3
    http://www.excelfox.com/forum/f13/bb...2077/#post9631

    PHP Code:
    Sub BB_Table_Clipboard()
        
        
    Dim BB_Row As RangeBB_Cells As RangeBB_Range As Range
        Dim BB_Code 
    As StringstrFontColour As StringstrBackColour As StringstrAlign As StringstrWidth 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.50)
            
    BB_Code BB_Code "[td=" """" "bgcolor:#ECF0F0, align:center, width:" strWidth """" "][B]" Split(BB_Cells.Address"$")(1) & "[/B][/td]" vbNewLine
        Next BB_Cells 
    _........................

    But , the same code bit of Admin's copied first to my the VB Editor, and then back to a php window it does not work again….

    PHP Code:
    Sub BB_Table_Clipboard()        Dim BB_Row As RangeBB_Cells As RangeBB_Range As Range    Dim BB_Code As StringstrFontColour As StringstrBackColour As StringstrAlign As StringstrWidth 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.50)        BB_Code BB_Code "[td=" """" "bgcolor:#ECF0F0, align:center, width:" strWidth """" "][B]" Split(BB_Cells.Address"$")(1) & "[/B][/td]" vbNewLine    Next BB_Cells 
    Last edited by DocAElstein; 01-21-2016 at 08:34 PM.

  5. #5
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    spare Post, may need later if the next ones work....

    EDIT: It did work

    so, as it worked.. To share:


    So I have a Work around…… ( which I do not understand.. ) … to get a code with strings containing BB Code to come up ( in a php Window ) which can then be copied to a VB Editor Code Window. ( Normal copying to between BB Code Tags ( as well as simple copying to between php BB Code Tags ) does not work … (… for me… Poo! ) )


    _1 ) I copy a few lines from any code from a php Window that does appear to look normal……
    _2 ) I paste that code bit into a spare WORD document. ( I have WORD 2007 )
    _2a ) I notice that the text appears to be nested in a light grey background….
    _3 ) Somewhere in the middle of that code I hit ENTER to get a few empty lines
    _4 ) I copy my code from the VB Editor into the WORD document at the point of the spare lines I made
    _4a) I notice that my code also appears to be nested in a light grey background.
    _5 ) I now copy that into a php Window in a Thread post ( To do that I either; hit the php icon in the symbol in the Forum Editor and paste my code into the php BB Code Tag pair which appears; or paste in my code, highlight it and hit the hit the php icon in above in the symbol ribbon in the Forum Editor. )
    Last edited by DocAElstein; 03-09-2016 at 04:45 PM.

  6. #6
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    First Declaring Bit of my Code version of the code from Pike, Kris and Rick.


    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/
    '
    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
    Private Const GHND = &H42
    Private Const CF_TEXT = 1
    Private Const MAXSIZE = 4096 

  7. #7
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    Some required Functions




    PHP Code:
    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       http://www.excelfox.com/forum/f13/summary-of-maximum-rows-used-across-each-sheet-in-a-workbook-2053/#post9482
    Good for any positive Long
        
    If iCol 0 Then
        ColLtr 
    ColLtr((iCol 1) \ 26) & Chr(65 + (iCol 1Mod 26)
        Else
        
    End If
    End Function 
    Last edited by DocAElstein; 01-21-2016 at 09:05 PM.

  8. #8
    Fuhrer, Vierte Reich DocAElstein's Avatar
    Join Date
    Aug 2014
    Posts
    9,270
    Rep Power
    10
    PHP Code:
    Sub BB_Table_Clipboard()
       
        
    Dim BB_Row As RangeBB_Cells As RangeBB_Range As Range
        Dim BB_Code 
    As StringstrFontColour As StringstrBackColour As StringstrAlign As StringstrWidth 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.50)
            
    BB_Code BB_Code "[td=" """" "bgcolor:#ECF0F0, align:center, width:" strWidth """" "][B]" Split(BB_Cells.Address"$")(1) & "[/B][/td]" vbNewLine
        Next BB_Cells 

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


    PHP Code:
    Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/
        
        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 "[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]"
        '
    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 

  10. #10

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
  •