test BB Code

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

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 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 = 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. 9zYoeePv8sZ9zYqog9KZ5B
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9zYlZPKdOpm
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA

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

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


---

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

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


---

PHP Code:

---

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 


---

spare Post, may need later if the next ones work....:)

EDIT: It did work %O

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

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 


---

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 


---

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), 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       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 - 1) Mod 26)
    Else
    End If
End Function 


---

File with codes
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9

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


---

Alan

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

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

---

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


---

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

---

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

---

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

---

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

---

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

---

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

---

IE 11

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


---

Google Chrome

PikeCode

Code:

---

Option Explicit'  http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096


Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
    Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
    Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String


    Set BB_Range = Selection
    BB_Code = "

v	" & Split(BB_Cells.Address, "$")(1) & "
" & BB_Row.Row & "	[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]

"
    ClipBoard_SetData (BB_Code)
    Set BB_Range = Nothing
End Sub


Private Function objColour(strCell As String) As String
    objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function


Private Function FontAlignment(ByVal objCell As Object) As String
    With objCell
        Select Case .HorizontalAlignment
        Case xlLeft
            FontAlignment = "LEFT"
        Case xlRight
            FontAlignment = "RIGHT"
        Case xlCenter
            FontAlignment = "CENTER"
        Case Else
            Select Case VarType(.Value2)
            Case 8
                FontAlignment = "LEFT"
            Case 10, 11
                FontAlignment = "CENTER"
            Case Else
                FontAlignment = "RIGHT"
            End Select
        End Select
    End With
End Function


Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
    Dim hGlobalMemory As Long, lpGlobalMemory As Long
    Dim hClipMemory As Long, X As Long


    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Could not unlock memory location. Copy aborted."
        GoTo OutOfHere2
    End If
    If OpenClipboard(0&) = 0 Then
        MsgBox "Could not open the Clipboard. Copy aborted."
        Exit Function
    End If
    X = EmptyClipboard()
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "Could not close Clipboard."
    End If
End Function

---

HTML Code:

---

Option Explicit'  http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html'Pike    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370'Copy the syntax in the "VB:" window below to a standard Module'Select the range in the worksheet to be converted'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370    Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range    Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
    Set BB_Range = Selection    BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine    BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine    For Each BB_Cells In BB_Range.Rows(1).Cells        strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine    Next BB_Cells    BB_Code = BB_Code & "[/tr]"    For Each BB_Row In BB_Range.Rows        BB_Code = BB_Code & "[tr]"        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine        For Each BB_Cells In BB_Row.Cells            strFontColour = objColour(BB_Cells.Font.Color)            strBackColour = objColour(BB_Cells.Interior.Color)            strAlign = FontAlignment(BB_Cells)            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine        Next BB_Cells        BB_Code = BB_Code & "[/tr]" & vbNewLine    Next BB_Row    BB_Code = BB_Code & "[/table]"    ClipBoard_SetData (BB_Code)    Set BB_Range = NothingEnd Sub
Private Function objColour(strCell As String) As String    objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function
Private Function FontAlignment(ByVal objCell As Object) As String    With objCell        Select Case .HorizontalAlignment        Case xlLeft            FontAlignment = "LEFT"        Case xlRight            FontAlignment = "RIGHT"        Case xlCenter            FontAlignment = "CENTER"        Case Else            Select Case VarType(.Value2)            Case 8                FontAlignment = "LEFT"            Case 10, 11                FontAlignment = "CENTER"            Case Else                FontAlignment = "RIGHT"            End Select        End Select    End WithEnd Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this    Dim hGlobalMemory As Long, lpGlobalMemory As Long    Dim hClipMemory As Long, X As Long
    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)    lpGlobalMemory = GlobalLock(hGlobalMemory)    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)    If GlobalUnlock(hGlobalMemory) <> 0 Then        MsgBox "Could not unlock memory location. Copy aborted."        GoTo OutOfHere2    End If    If OpenClipboard(0&) = 0 Then        MsgBox "Could not open the Clipboard. Copy aborted."        Exit Function    End If    X = EmptyClipboard()    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2:    If CloseClipboard() = 0 Then        MsgBox "Could not close Clipboard."    End IfEnd Function

---

After running cod to put in vbCR

HTML Code:

---

'    http://www.eileenslounge.com/viewtopic.php?f=26&t=22603&start=20#p176255        http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9687  ( Manual Solution Alternative: http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9645 )
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

---

Code:

---

Option Explicit'  http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike    http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096


Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
    Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
    Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String


    Set BB_Range = Selection
    BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
    BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
    For Each BB_Cells In BB_Range.Rows(1).Cells
        strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
    Next BB_Cells
    BB_Code = BB_Code & "[/tr]"
    For Each BB_Row In BB_Range.Rows
        BB_Code = BB_Code & "[tr]"
        BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
        For Each BB_Cells In BB_Row.Cells
            strFontColour = objColour(BB_Cells.Font.Color)
            strBackColour = objColour(BB_Cells.Interior.Color)
            strAlign = FontAlignment(BB_Cells)
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
        Next BB_Cells
        BB_Code = BB_Code & "[/tr]" & vbNewLine
    Next BB_Row
    BB_Code = BB_Code & "[/table]"
    ClipBoard_SetData (BB_Code)
    Set BB_Range = Nothing
End Sub


Private Function objColour(strCell As String) As String
    objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function


Private Function FontAlignment(ByVal objCell As Object) As String
    With objCell
        Select Case .HorizontalAlignment
        Case xlLeft
            FontAlignment = "LEFT"
        Case xlRight
            FontAlignment = "RIGHT"
        Case xlCenter
            FontAlignment = "CENTER"
        Case Else
            Select Case VarType(.Value2)
            Case 8
                FontAlignment = "LEFT"
            Case 10, 11
                FontAlignment = "CENTER"
            Case Else
                FontAlignment = "RIGHT"
            End Select
        End Select
    End With
End Function


Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
    Dim hGlobalMemory As Long, lpGlobalMemory As Long
    Dim hClipMemory As Long, X As Long


    hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
    lpGlobalMemory = GlobalLock(hGlobalMemory)
    lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
    If GlobalUnlock(hGlobalMemory) <> 0 Then
        MsgBox "Could not unlock memory location. Copy aborted."
        GoTo OutOfHere2
    End If
    If OpenClipboard(0&) = 0 Then
        MsgBox "Could not open the Clipboard. Copy aborted."
        Exit Function
    End If
    X = EmptyClipboard()
    hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
    If CloseClipboard() = 0 Then
        MsgBox "Could not close Clipboard."
    End If
End Function

---

Code:

---

v
" & Split(BB_Cells.Address, "$")(1) & "


" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]




"

---

Code:

---

Sub AlanHansClipboardTextGetFindReplace() 'Using the "Dialogue Find Replace" way.
Rem 1) Put Selected Text in Clipboard.
Dim objCliS As DataObject '**Early Binding. Object from the class MS Forms, This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. It has the Methods I need to send text to the Clipboard. I will use this to put Things in the Clipboard. Bringing things out I will do with another Data Object
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 which is the same ). or next two lines are...
'Dim objCliS As Object ' ...Late Binding equivalent'
'Set objCliS = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/l...ms-dataobject/
Dim Txtin As String: Let Txtin = Selection.Text: Debug.Print Txtin 'Copies the selection as a continuous string: Hit Ctrl G to see it in the Immediate window! You will see it with carriage returns , the Copmuter just sees it as a long "Horizontal" string
objCliS.SetText Txtin 'Make object's text equal above string variable
objCliS.PutInClipboard 'Place current object dataObject into the Clipboard ( Our original selected text ....!!!.... is in that )
'Rem 2) 'Bit of a bodge to get the text in a selection: create a Word file and paste to it
Dim FullFilePathAndFullName As String 'Initial Pigion Hole given for this String variable, and given a special vbNullString "Value", theoretically to simplify comparisons.
Documents.Add: ActiveDocument.Content.Paste 'Make a File Copy in current Application based on Default Type : And Paste from Clipoard ( ...!!!...our original selected text ) using the Default Copy which should at least have all the text, which is all we are interested in here.
ActiveDocument.SaveAs Filename:="TempBBCodeCopyTidledInSpaces.docx", FileFormat:=wdFormatXMLDocument 'Without this the document will not really "exist jet". It has a tempory name ( Used in Windows referrence ), but no path.
Let FullFilePathAndFullName = ActiveDocument.path & "\" & ActiveDocument.Name
Selection.WholeStory 'Selects whole document which here is just our selection of interest from the oroiginal document
'Rem 3) Han's Text Find Replacement Dialogue 'http://www.eileenslounge.com/viewtopic.php?f=26&t=22603#p175712
With Selection.Find 'This is the VBA code ( or very similar ) used by Excel when Using the Find eplace text Dialogue box. So this is an improved version of what a macro recording would give.
.ClearFormatting: .Replacement.ClearFormatting ' Don't use formatting, ? not sure this comes into the equation ??
.Wrap = wdFindStop ' Tell Word not to continue past the end of the selection ( And therefore prevents also a display Alert asking )
.MatchWildcards = False ' Don't use wildcards. The default anyway, but in this code is an important concept...
.Text = " " ' Search text is two spaces
.Replacement.Text = "~~" ' Replace text is with two tildas.
.Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
.Text = "~ " ' Search text is tilda followed by space
.Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
.Text = "~{1;}" 'or [~]{1;} It is still not totally clear whether this is a Reg Ex Pattern or a Wild Card String. Important is that it is a String in a Dialogue to be applied to A ( Word in this case ) document. Sort of as you write in a cell, so the ; , convention must be carefully checked and appropriately used here
.Replacement.Text = "^&" ' Enclose in BB codes ...... This "Wildcard" applies only to the Replace. It inserts the found string, or strings.
.MatchWildcards = True 'The next line does the Replce, here we are still selecting an option,( Use wildcards )
.Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
End With
ActiveDocument.Select 'Re select the...( actually this line alone seems to do it )
Selection.WholeStory '...while document
Rem 4) "Reset the "Find Replace Text Dialogue" "Thing" "
With Selection.Find
.ClearFormatting: .Replacement.ClearFormatting: .Text = "": .Replacement.Text = "": .Forward = True: .Wrap = wdFindAsk: .Format = False: .MatchCase = False: .MatchWholeWord = False: .MatchKashida = False: .MatchDiacritics = False: .MatchAlefHamza = False: .MatchControl = False: .MatchWildcards = False: .MatchSoundsLike = False: .MatchAllWordForms = False '
End With
Rem 5) Final result to and from Clipboard
'5b) Using again objCliS we put the modified text in the Clipboard, so overwritng the original
objCliS.SetText Selection.Text 'Replace the text in the data object
objCliS.PutInClipboard 'Place current object dataObject into the Clipboard, so putting the modified text in there
'5b) Another data Object to get the data from the 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 second instance of the Class.
Dim TxtOut As String: Let TxtOut = objDat.GetText() 'retrieve the text in this second instance of the Class. ( In this case all I have in it is the text )
MsgBox prompt:="You dumped in Clipboard this " & vbCr & objCliS.GetText() & vbCr & "and if you try to get it, you should get" & vbCr & TxtOut & ""
Rem 6) Optional to delete Temporary File
ActiveDocument.Close (wdDoNotSaveChanges) 'Giving the option will also prevent being asked for it. You must close. VBA will not let you kill an open sheet, as you are affectively working on a copy, and VBA is assumng the Original can be got at by saving for example. http://www.mrexcel.com/forum/excel-q...ml#post4425428
Kill FullFilePathAndFullName 'Use the Kill wisely!!!! - where this goes there 'aint no coming back!!
End Sub

---

Pike FontFartsWonks
http://www.excelfox.com/forum/showth...-BB-Code/page3
....there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list


Old:
Using Excel 2007

Row\Col	F	G
14	PikeCalibri	Fooaarrnst Arial Narrow
15	Verdana	Batang

Sheet: Molly

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


New Fonts

Using Excel 2007

Row\Col	F	G
14	PikeCalibri	Fooaarrnst Arial Narrow
15	Verdana	Batang

Sheet: Molly

http://www.excelfox.com/forum/showth...=9801#post9801
Piike 16 may 2016
..........there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list.................................

Code:

---

' To Copy this to a Forum Post you need Alan's HTML Text for copy in HTML Window Bodge Wonk http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9639




'  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()
'  PikeFoarnts  16th Mai 2016  --XX  http://www.excelfox.com/forum/showthread.php/2077-BBCode-Table?p=9801#post9801
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_PikeFoarnts() '    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
    Dim strFontName As String ' --XX
    '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
' --XX      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)
' --XX      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
            strFontColour = objColour(BB_Cells.Font.Color)
            strBackColour = objColour(BB_Cells.Interior.Color)
            strAlign = FontAlignment(BB_Cells)
            strFontName = BB_Cells.Font.Name
            BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """][Font=""" & strFontName & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/Font][/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 & "[size=" & 0 & "][Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table][/size]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
    ClipBoard_SetData (BB_Code)
BeepForPoo:  Beep: Beep: Application.Wait (Now + TimeValue("0:00:01")): Beep
MsgBox prompt:="You Dumped in Clipboard!"
Beep: Beep: Beep: Beep: Application.Wait (Now + TimeValue("0:00:01")): Beep: Beep
    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


'Alan HTML Text for copy in HTML Window Bodge Wonk http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9639
'_____________________________________________________________________________

---

ʅ_(ツ)_ʃ
__|
__|



Excel 2007 32 bit
got a new bit :rolleyes::rolleyes:

	G	H	I
5	Rory	appears	to
6	be	Playing	with
7	his	Tool	Today

Sheet: Molly

:rolleyes:
http://www.mrexcel.com/forum/about-b...ad-code-2.html
:rolleyes::rolleyes:




Using Excel 2007 32 bit

Row\Col	G	H	I
5	Rory	appears	to
6	be	Playing	with
7	his	Tool	Today

Molly

Edit has he lost his row abd column?
or did I
Excel 2007 32 bit

	G	H	I
5	Rory	appears	to
6	be	Playing	with
7	his	Tool	Today

Sheet: Molly

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



For Info on Add-Ins see my signature and
http://www.excelforum.com/the-water-...ml#post4109080

. Hi.
Here are Some notes on an Add-In which allows you to paste a screenshot of a Spreadsheet range, in a form that we can copy to a Spreadsheet.
Here is the current Add-In from Rory Archibald, which he maintains and updates regularly
https://www.dropbox.com/s/31r9s6t9j6...ools.xlam?dl=0

Here are some Add-In versions of mine with minor modifications to the original above
https://app.box.com/s/oa1zouz1ksm68yevndee6yi1v1o0qmmm
https://app.box.com/s/7v5no8t18qqzjwyfqtv1xo5elsyba3o6
https://app.box.com/s/boxjrj2wmlren3tgqqnamzxknnpwyaut

…. I wrote some „Beginners type" Notes on how to get these Add-Ins working, referenced in my signature, again here the link:
https://app.box.com/s/gjpa8mk8ko4vkwcke3ig2w8z2wkfvrtv
. I am sure many Regulars do not need those notes, but possibly beginners like me wishing to use the Add-In may find them useful. Here they are given again below - Appologies that the images are in German. Hopefully the Pictures are still helpful in confirming the steps

A simple Code alternative from Pike is given here:
http://www.excelfox.com/forum/showth...=9805#post9805
Alan

P.s. For all codes, what you do is basically is
Highlight the range you wish to copy.
Copy it to the Clipboard ( Ctrl + C )
Paste in a Forum Post Editor.
It should then look like a lot of BB Code, but when posted it should come out as a Table.
Test here:
http://www.excelfox.com/forum/forumd...p/17-Test-Area

.................................................. ...................

[CENTER][U][B] Notes on Typical Download procedure for Forum Tool "Add

I often hit the post size character limit.
So every bit of saving of character usage is helpful to me
I often use Rory's Screenshot Tool.
I noticed it had a bit that for every row defined the background colour as white.
I took it out and it seems to have no effect on final output.
So that little change saves a bit of character space for me.
So:-
Taking out the “white background color”.
This is the default background row color, I think. It seems to come out at white anyway, so I took out the explicit “making it white bit”. In long deep tables that will save quite a few characters in the BB Code.
I did this, ‘cos I could ;)
So I did this simple Mod in the Private Function RngToBBC in the mBBCode Normal Code Module, (Basically I just edited out the bit in shown in red)

Code:

---

            'sOut = sOut & vbNewLine & "[tr=bgcolor:" & csROW_BACK & "]"
            sOut = sOut & vbNewLine & "[tr]" 'Remove white background for entire row
            If bHdr Then sOut = sOut & "[td=bgcolor:" & csHEADER_BACK & "]

[COLOR=" & csHEADER_COLOR & "]" & rRow.Row & "[/COLOR]

[/td]"

---

So it used to produce this:
[color=lightgrey]Using Excel 2007 32 bit[/color]
[size=0][Table="width:, class:head"][tr=bgcolor:skyblue][th][COLOR=black][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th][th][CENTER][COLOR=black]J[/COLOR][/CENTER][/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:skyblue][CENTER][COLOR=black][b]35[/b][/COLOR][/CENTER][/td][td][/td][/tr]
[/table][/size][size=0][color=lightgrey]Worksheet: [/color][b][color=darkblue]Intercepts[/b][/color][/size]
Using Excel 2007 32 bit

Row\Col	J
35

Worksheet: Intercepts

After the small code mod I get this:
[color=lightgrey]Using Excel 2007 32 bit[/color]
[size=0][Table="width:, class:head"][tr=bgcolor:skyblue][th][COLOR=black][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th][th][CENTER][COLOR=black]F[/COLOR][/CENTER][/th][/tr]
[tr][td=bgcolor:skyblue][CENTER][COLOR=black][b]32[/b][/COLOR][/CENTER][/td][td][/td][/tr]
[/table][/size][size=0][color=lightgrey]Worksheet: [/color][b][color=darkblue]Intercepts[/b][/color][/size]
Using Excel 2007 32 bit

Row\Col	F
32

Worksheet: Intercepts

This remains a jolly spiffing super Tool in my opinion. I have erected it in more places and more times than I care to remember. It really is the Doggies best :)
http://www.excelforum.com/showthread...=3#post4573121
http://www.excelfox.com/forum/showth...0055#post10055
http://excelmatters.com/excel-forums/#comment-199330

Get the Color shade you want to come out in Final Post

I expect there is a better way to do this, but I just hit on a way that works quite well, so I will document and share that now , and edit and update later if I come up with a more scientific and/ or automated way.

As an example , say I have seen this: _ shade _ somewhere, as you see it here, ( there ) . Lets assume I want to post that word in a Forum editor which accepts BB Code tags, ( BB Code tags: http://www.excelfox.com/forum/misc.php?do=bbcode ) such that I get that _ shade _ in the final post just as you see it here ( there )

Here is a way to do it:
_1 ) Use Word to get the shade of shade that you want,
__________________________________:rolleyes: :for example,
_ 1A) highlight any text and experiment with its color:
Word Text Color 0.JPG : https://imgur.com/xpCoo8B
Word Text Color 1 2.JPG : https://imgur.com/agdUo2f
Word Text Color 3.JPG : https://imgur.com/H5czlGV
Word Text Color 4.JPG : https://imgur.com/2ff71Xq
( Hit OK when finished to change selection color)
Attachment 1981Attachment 1982Attachment 1983Attachment 1984

_ 1B) As an alternative start point, you can find any text color anywhere, for example in the internet, paste into Word and adjust it in Word as per _ 1A)

_2 ) Copy the final Text to the clipboard.
Search the internet for any Word to HTML converter, there are many free ones available. Typically you can paste anything into a Visual Editor and then choose to obtain the HTML code
WordVisualToHTML.JPG : https://imgur.com/T19SMxG
Attachment 1980

_3 ) In the given HTML code will typically be some part referring to the text shade,_..

HTML Code:

---

<p><span style="font-size: 11pt; line-height: 115%; font-family: Verdana, sans-serif; color: #417394;">shade</span></p>

---

_.. here for example, the number of interest is _ color: #417394

_4 ) I assume the number used in the square bracket [ BB Code Color Tags ] pair is the same as in pointy bracket < HTML > code Tags color bit. It appears to be.
So for our example shade you would use this in a forum post_..
____ [color=#417394] shade [/color]
_.. which would come out like this:
__Scrol Tumy_____ shade

( If you want to keep the indent, as I did here (there), and avoid the forum editor “eating” spaces of more than one, ( as most forum editors do this ) ) , then use the white character trick: Post something like this:
[color=white]_ Any_White_Profanity Text [/color] [color=#417394] shade [/color]




Alan

DocAElstein
[color=#417394]
[B][u]DocAElstein[/u][/B][/color]
https://imgur.com/MKMjW0b



Ref
http://www.excelfox.com/forum/showth...plete-Document
https://imgur.com/MKMjW0b
http://www.excelfox.com/forum/misc.php?do=bbcode
https://wordtohtml.net/
http://services.runescape.com/m=foru...9,877,64690220
http://www.excelfox.com/forum/showth...age2#post10131


_.________________________________________________ _
Miscillanus Testies
Using Excel 2007 32 bit

Row\Col	A
1	S No

Worksheet: Sheet1
[color=lightgrey]Using Excel 2007 32 bit[/color]
[size=0][Table="width:, class:head"][tr=bgcolor:#417394][th][COLOR=black][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th][th][CENTER][COLOR=black]A[/COLOR][/CENTER][/th][/tr]
[tr][td=bgcolor:#417394][CENTER][COLOR=black][b]1[/b][/COLOR][/CENTER][/td][td][CENTER][B]S No[/B][/CENTER][/td][/tr]
[/table][/size][size=0][color=lightgrey]Worksheet: [/color][b][color=darkblue]Sheet1[/b][/color][/size]
[s][/s]

== NO PARSE ==

[b]Unparsed[/b] [u]text[/u]

Snow

To Here: https://excelfox.com/forum/showthrea...ll=1#post10545

---

<p align=center style="font-family:'Verdana';font-size:11pt;color:blue;background:white"><span style="color:#0070C0"><u>Error and Error Handling VBA <b>Summary</b></u></span></p>
<table cellpadding="1px" rules="all" style=";background-color:#FFFFFF;border:1px solid;border-collapse:collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color:#E0E0F0"/>

<tr>
<td style="border:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:10pt">
<p align=center style="font-size:11pt;font-family:'Verdana'">Error Handling Code line <span style="color:white">ORNeRe_GoRoT_N0Nula_1_____<spa n>
</td>
<td style='border:solid windowtext 1.0pt;border-left:none;padding:0cm 3.5pt 0cm 3.5pt;height:10pt'>
<p align=center style="font-size:11pt;font-family:'Verdana'">Notes</p>
</td>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;padding:0cm 3.5pt 0cm 3.5pt;height:39.85pt">
<p style="font-size:8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">On Error Resume Next</span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:39.85pt'>
<p align=left style="font-size:11pt;font-family:'Verdana'" >Makes code always carry on after error line.&nbsp; Clears the exception – So it works time and time again, &nbsp;&nbsp; <b>But</b> retains infomation of last error in Err object&nbsp;&nbsp; The further runing of code is normal code running as that running previous to the error, with the error handling enabled but not active. ( Effectively the error handler is only very briefely active at the error occurance time)</p>
</td>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;height:34.75pt">
<p style="font-size: 8pt;font-family:'courier new'"><span style="color:#0070C0">On Error GoTo </span><span style="color:lightgrey">Label/Line </span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:34.75pt'>
<p align=left style="font-size:11pt;font-family:'Verdana'">Does not clear the exception. &nbsp;&nbsp; Just goes to the indicated Label or Line Number &nbsp;&nbsp; (Typically at that label or line number would be code lines for an error handling routine ) &nbsp;&nbsp; It is Prevented by default ( due to it not clearing the exception ) from working more than once &nbsp;&nbsp; The futher running code is effectively part of the Exception running software. The error handler is therefore active continuously aftert the error occurance.</p>
<p align=left style="font-size:11pt;font-family:'Verdana'">Note this does the disable and Clear in either the normal or exception state</p>
</td>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;padding:0cm 3.5pt 0cm 3.5pt;height:21.75pt">
<p style="font-size: 8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">On Error GoTo</span> <span style="color:black"> 0</span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;mso-border-top-alt:solid windowtext .5pt;padding:0cm 3.5pt 0cm 3.5pt;height:21.75pt'>
<p align=left style="font-size:11pt;font-family:'Verdana'">Does not clear the exception &nbsp;&nbsp; !! Disables any enabled error handler &nbsp;&nbsp; This Clears the <span style="font-family:'courier new'">Err</span> object</p>
</td>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;padding:0cm 3.5pt 0cm 3.5pt;height:21.35pt">
<p style="font-size: 8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">On Error GoTo</span> <span style="color:black"> -1</span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:21.35pt'>
<p align=left style="font-size:11pt;font-family:'Verdana'">Clears the exception , (* in other words, Deactivates any enabled error handler)<b> Does not</b> disable any enabled error handler &nbsp;&nbsp; This Clears the <span style="font-family:'courier new'">Err</span> object</p>
</td>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;padding:0cm 3.5pt 0cm 3.5pt;height:29.1pt">
<p style="font-size: 8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">Resume</span></p>
</td>
<td style="border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:29.1pt">
<p align=left style="font-size:11pt;font-family:'Verdana'">Clears the exception, (in othert words * Deactivates any enabled error handler) &nbsp;&nbsp; <b> Does not</b> disable any enabled error handler. &nbsp; Makes code try again at error line. ( Be careful as can lead to an infinite loop of retrying!) &nbsp; <b>Does not</b> retain infomation of last error: Clears <span style="font-family:'courier new'">Err</span> object &nbsp;&nbsp; Typical usage would be as the last code line in an error handling code section sent to with <span style="color:#0070C0">On Error GoTo </span><span style="color:lightgrey">Label/Line </span> </p>
</td>
</tr>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;height:21.35pt">
<p style="font-size: 8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">Resume Next</span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:21.35pt'>
<p align=left style="font-size:11pt;font-family:
'Verdana'"> As <span style="color:#0070C0">Resume</span> , but resumes after line which errored</p>
</td>
</tr>

<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;padding:0cm 3.5pt 0cm 3.5pt;height:21.35pt">
<p style="font-size: 8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">Resume</span> <span style="color:lightgrey">Label/Line Number </span> </span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:21.35pt'>
<p align=left style="font-size:11pt;font-family:'Verdana'"> As <span style="color:#0070C0">Resume</span> , but resumes <b>at</b> <span style="color:lightgrey">Label/Line number</span></p>
</td>
</tr>
</table>
<p style="font-family:'Verdana';font-size: 11pt"> * Deactivated means: "The trap is reset: but not currently working - It is "primed" ". It is enabled, but not activated. &nbsp; &nbsp; !! Disabled means its "no longer there", so you are back to default VBA error handler</p>
<p style="font-family:'Verdana';font-size: 11pt"> <span style="font-family:'courier new'">Err</span> : An object. (Possibly a not too well thought out VBA type pseudo object, being strangely read or write). 6 Properties containing strings of information about last error & 2 Methods, <span style="font-family:'courier new'">.Raise</span> and <span style="font-family:'courier new'">.Clear</span> &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; <span style="font-family:'courier new'">.Clear</span> simply empties the string infomation Properties of <span style="font-family:'courier new'">Err</span></p>
<p style="font-family:'Verdana';font-size: 11pt"> <span style="font-family:'courier new'">Erl</span> : A Function or Method effectively returning line number of last error or 0 if no line number is present at erroring code line. It is possible this is just an old thing only working in the exception state to give the last excecuted line in the normal state. </p>
<p style="font-family:'Verdana';font-size: 11pt"> <span style="font-family:'courier new'">vbObjectError</span> : Probably broken or no one remembers what it does - A plie of wank - forget about it! </p>

For sandy....

Quote:

---

where I can change color of the headers font in Forum Tool add-in?

---

I don't have the current newest version, but I think my old version is similar.....

Current: ( This is my version which I have already modified many times )

Using Excel 2007 32 bit

Row\Col	A	B	C
1	Date	Name	Laps
2	05. Apr	Dan	23

Worksheet: Tabelle1

__ Alt+F11 (VB Editor Window)
__ 1 Forum Tools --- 2 Module --- 3 mBBCode
1 Forum Tools --- 2 Module --- 3 mBBCode.JPG : https://imgur.com/Rl95Bol
Attachment 2059

Code:

---

Private Function RngToBBC(rInp As Range, _
                          iSize As Long, _
                          Optional bHdr As Boolean = True, _
                          Optional bFrm As Boolean = False, _
                          Optional bA1 As Boolean = False, _
                          Optional bColour As Boolean = False) 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 = "#417394"
    'Const csHEADER_BACK As String = "skyblue"
    Const csROW_BACK As String = "#FFFFFF"
    Dim sOut                  As String
    Dim rRow                  As Range
    Dim Cell                  As Range

---

_.________________-

Now Change to red for sandy...
Using Excel 2007 32 bit

Row\Col	A	B
1	Date	Name
2	05. Apr	Dan

Worksheet: Tabelle1

Code:

---

Private Function RngToBBC(rInp As Range, _
                          iSize As Long, _
                          Optional bHdr As Boolean = True, _
                          Optional bFrm As Boolean = False, _
                          Optional bA1 As Boolean = False, _
                          Optional bColour As Boolean = False) 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 = "#417394"
    Const csHEADER_BACK As String = "red"
    'Const csHEADER_BACK As String = "skyblue"
    Const csROW_BACK As String = "#FFFFFF"
    Dim sOut                  As String
    Dim rRow                  As Range
    Dim Cell                  As Range

---

_.______________________________________
Some test of mSettings code module
Using Excel 2007 32 bit

Row\Col	A	B
1	Date	Name
2	05. Apr	Dan

Worksheet: Tabelle1
Using Excel 2007 32 bit

Row\Col	A	B
1	Date	Name
2	05. Apr	Dan

Worksheet: Tabelle1
Using Excel 2007 32 bit

Row\Col	A	B
1	Date	Name
2	05. Apr	Dan

Worksheet: Tabelle1
Using Excel 2007 32 bit

Row\Col	A	B
1	Date	Name
2	05. Apr	Dan

Worksheet: Tabelle1
No changes in my old version

still no changes with this:

Code:

---

#If VBA7 Then
    Public Const TB_BORDER_COLOR As String = "#BBB"
    'Public Const COLHDR_BCKGRND_COLOR As String = "#DAE7F5"
    Public Const COLHDR_BCKGRND_COLOR As String = "red"
    Public Const ROWHDR_BCKGRND_COLOR As String = "#DAE7F5"
    Public Const ROWHDR_BORDER_COLOR As String = "#BBB"
    Public Const ROWHDR_FONT_COLOR As String = "#161120"
#Else
    Public Const TB_BORDER_COLOR As String = "#A6AAB6"
    'Public Const COLHDR_BCKGRND_COLOR As String = "#E0E0F0"
    Public Const COLHDR_BCKGRND_COLOR As String = "red"
    Public Const ROWHDR_BCKGRND_COLOR As String = "#E0E0F0"
    Public Const ROWHDR_BORDER_COLOR As String = "#A6AAB6"
    Public Const ROWHDR_FONT_COLOR As String = "#161120"
#End If

---

Using Excel 2007 32 bit

Row\Col	A	B
1	Date	Name
2	05. Apr	Dan

Worksheet: Tabelle1