test BB Code

[DocAElstein]

Test New Pike / Fox / Rick Code


Using Excel 2007

Row\Col
J
K
L5
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

[DocAElstein]

' 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version BB_Code = BB_Code & "" & vbNewLine 'BB_Code = BB_Code & "v" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) 'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row Next BB_Cells BB_Code = BB_Code & "" For Each BB_Row In BB_Range.Rows 'Row Numbers BB_Code = BB_Code & "" 'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" & vbNewLine Next BB_Row BB_Code = BB_Code & "" '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 = 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.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=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=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=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=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=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=312727#p312727)
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724 (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?f=44&t=40374&p=312535#p312535)
https://www.eileenslounge.com/viewtopic.php?p=312533#p312533 (https://www.eileenslounge.com/viewtopic.php?p=312533#p312533)
https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499 (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.9xhyRrsUUOM9xpn-GDkL3o)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg (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)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg.9zYoeePv8sZ9zYqog9KZ 5B)
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm (https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm)
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA (https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA)

[DocAElstein]

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/attachments/development-testing-forum/441618d1453300597-forum-tools-test-no-reply-needed-mollybbcodes.xlsm
http://www.excelforum.com/development-testing-forum/1086445-forum-tools-test-no-reply-needed.html#post4293889
http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9635



Sub ShowRangeToBBCFormRoryAForumTools()
Excel 2007
Row\Col
G
H

5Test Test
Sheet: Molly
Excel 2007
Row\Col
G
H

5Test =G5
Sheet: Molly


Sub ShowRangeToBBCFormJune()
Using Excel 2007
Row\Col
G
H

5Test Test
Molly
Using Excel 2007
Row\Col
G
H

5Test =G5
Molly

Sub ShowRangeToBBCFormSkyBlue()
Using Excel 2007
-
G
H

5Test Test
Molly
Using Excel 2007
-
G
H

5Test =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
H5
Test

Sheet: Molly

Sub BB_Table_Clipboard_PikeFoxAlan()
Using Excel 2007

Row\Col
J
K
L5
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

[DocAElstein]

Using Excel 2007

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

</tbody>

<tbody>
Sheet: Molly

</tbody>


Here a bit of my 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine 'BB_Code = BB_Code & "[tr]v" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) 'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row Next BB_Cells

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

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


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]v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & 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….


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]v" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine Next BB_Cells

[DocAElstein]

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]v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells

[DocAElstein]

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

[DocAElstein]

First Declaring Bit of my Code version of the code from Pike, Kris and Rick.



' 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

[DocAElstein]

Main 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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

[DocAElstein]

Some required Functions





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

[DocAElstein]

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

[DocAElstein]

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 = "A Text in Forum Post to come out Light Salmon in Color"
End Sub

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

Pasted in a code Window:


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


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


Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in 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/test-bb-code-2079/#post9641
http://www.excelfox.com/forum/f13/bbcode-table-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/viewtopic.php?f=26&t=22603&start=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.



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:


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



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

Alan

[DocAElstein]

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 = "A Text in Forum Post to come out Light Salmon in Color"
End Sub

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

Pasted in a code Window:


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


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


Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "A Text in Forum Post to come out Light Salmon in 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

[DocAElstein]

IE 11 HTML Tags


' 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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/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

[DocAElstein]

IE 11 PHP Tags


' 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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/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

[DocAElstein]

IE 11 BB Code Tags


' Convert Excel range to BBCode Table - Page 2 (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/ Convert Excel range to BBCode Table - Page 2 (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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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/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 VBA Column Letter from Column Number. Explained. (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

[DocAElstein]

Google Chrome
from
http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613



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 = "
<tbody>
v
" & Split(BB_Cells.Address, "$")(1) & "


" & BB_Row.Row & "
" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "

</tbody>
"
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

[DocAElstein]

Google Chrome from here

Convert Excel range to BBCode Table - Page 2 (http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613)


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 = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
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

[DocAElstein]

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 = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
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

[DocAElstein]

IE 11



' Convert Excel range to BBCode Table - Page 2 (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/ Convert Excel range to BBCode Table - Page 2 (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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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/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 VBA Column Letter from Column Number. Explained. (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

[DocAElstein]

IE11



' 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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/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

[DocAElstein]

IE 11


' 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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/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

[DocAElstein]

Google Chrome

PikeCode


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 = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub


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


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


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


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

[DocAElstein]

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 = "" & vbNewLine BB_Code = BB_Code & "v" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0) BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" For Each BB_Row In BB_Range.Rows BB_Code = BB_Code & "" BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine Next BB_Cells BB_Code = BB_Code & "" & vbNewLine Next BB_Row BB_Code = BB_Code & "" 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

[DocAElstein]

After running cod to put in vbCR


' 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

[DocAElstein]

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 = "" & vbNewLine
BB_Code = BB_Code & "v" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & ""
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub


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


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


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


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

[pike]

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


" & BB_Row.Row & "
" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "




"

[DocAElstein]

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

[DocAElstein]

Pike FontFartsWonks
http://www.excelfox.com/forum/showthread.php/2079-test-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

<tbody>
Row\Col

F


G



14
PikeCalibri
Fooaarrnst Arial Narrow


15
Verdana
Batang

</tbody>

<tbody>
Sheet: Molly

</tbody>
_.................................................


New Fonts

Using Excel 2007

Row\Col
F
G14
PikeCalibri
Fooaarrnst Arial Narrow
15
Verdana
Batang
Sheet: Molly

[DocAElstein]

http://www.excelfox.com/forum/showthread.php/2077-BBCode-Table?p=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.................................




' 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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "" & vbNewLine
'BB_Code = BB_Code & "v" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "]Row\Col" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.Col umnWidth * 7.5, 0)
'BB_Code = BB_Code & "" & Split(BB_Cells.Address, "$")(1) & "" & vbNewLine
BB_Code = BB_Code & "
" & ColLtr(BB_Cells.Column) & "" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & ""
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & ""
'BB_Code = BB_Code & "" & BB_Row.Row & "" & vbNewLine
BB_Code = BB_Code & "" & BB_Row.Row & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & 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 & "" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "" ' & vbNewLine
Next BB_Row
BB_Code = BB_Code & ""
'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)
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
'_________________________________________________ ____________________________

[DocAElstein]

ʅ_(ツ)_ʃ
__|
__|



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

G
H
I

5Roryappearsto


6bePlayingwith


7his Tool Today
Sheet: Molly

:rolleyes:
http://www.mrexcel.com/forum/about-board/942937-forum-tool-add-bad-code-2.html
:rolleyes::rolleyes:




Using Excel 2007 32 bit
Row\Col
G
H
I

5Roryappearsto


6bePlayingwith


7his Tool Today
Molly


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

G
H
I

5Roryappearsto


6bePlayingwith


7his Tool Today
Sheet: Molly

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



For Info on Add-Ins see my signature and
http://www.excelforum.com/the-water-cooler/1068075-just-testing-img-cannot-do-it-in-test-forum-as-img-is-off-there-no-reply-needed-2.html#post4109080

[DocAElstein]

. 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/31r9s6t9j69lkab/Forum%20Tools.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/showthread.php/2077-BBCode-Table?p=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/forumdisplay.php/17-Test-Area

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

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

[DocAElstein]

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)

'sOut = sOut & vbNewLine & "=bgcolor:" & csROW_BACK & "]"[/color]
sOut = sOut & vbNewLine & "" 'Remove white background for entire row
If bHdr Then sOut = sOut & "
" & rRow.Row & ""

So it used to produce this:
Using Excel 2007 32 bit
[tr=bgcolor:skyblue]Row\Col
J

35
Worksheet: Intercepts
Using Excel 2007 32 bit
[tr=bgcolor:skyblue]Row\Col
J

35
Worksheet: Intercepts

After the small code mod I get this:
Using Excel 2007 32 bit
Row\Col
F

32
Worksheet: Intercepts
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.php?t=1086445&page=3#post4573121
http://www.excelfox.com/forum/showthread.php/2079-test-BB-Code?p=10055#post10055
http://excelmatters.com/excel-forums/#comment-199330

[DocAElstein]

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

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

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

<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_..
____ shade
_.. 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:
_ Any_White_Profanity Text shade




Alan

DocAElstein

DocAElstein
https://imgur.com/MKMjW0b



Ref
http://www.excelfox.com/forum/showthread.php/2057-Code-Mod-to-prevent-further-Replacement-Text-over-complete-Document
https://imgur.com/MKMjW0b
http://www.excelfox.com/forum/misc.php?do=bbcode
https://wordtohtml.net/
http://services.runescape.com/m=forum/forums.ws?278,279,877,64690220
http://www.excelfox.com/forum/showthread.php/2146-%E0%A4%AC%E0%A5%8D%E0%A4%B2%E0%A5%89%E0%A4%97-%E0%A4%95%E0%A5%8B%E0%A4%B6%E0%A4%BF%E0%A4%B6-%E0%A4%95%E0%A4%B0-%E0%A4%B0%E0%A4%B9%E0%A4%BE-%E0%A4%B9%E0%A5%88-%D8%A8%D9%84%D8%A7%DA%AF%D8%B2-%DA%A9%DB%8C-%DA%A9*Trying-Blogs/page2#post10131


_.________________________________________________ _
Miscillanus Testies
Using Excel 2007 32 bit
Row\Col
A

1
S No
Worksheet: Sheet1
Using Excel 2007 32 bit
Row\Col
A

1
S No
Worksheet: Sheet1


== NO PARSE ==

Unparsed text


Snow

[DocAElstein]

To Here: https://excelfox.com/forum/showthread.php/2079-test-BB-Code?p=10545&viewfull=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_____<span>
</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>

[DocAElstein]

For sandy....

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

1DateNameLaps


2
05. AprDan
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
2059


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

1DateName


2
05. AprDan
Worksheet: Tabelle1


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

1DateName


2
05. AprDan
Worksheet: Tabelle1
Using Excel 2007 32 bit
Row\Col
A
B

1DateName


2
05. AprDan
Worksheet: Tabelle1
Using Excel 2007 32 bit
Row\Col
A
B

1DateName


2
05. AprDan
Worksheet: Tabelle1
Using Excel 2007 32 bit
Row\Col
A
B

1DateName


2
05. AprDan
Worksheet: Tabelle1
No changes in my old version

still no changes with this:


#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

1DateName


2
05. AprDan
Worksheet: Tabelle1

[sandy666]

new FT is a different but I found it here and it works


#If VBA7 Then
#If USE_RGB Then
Public Const TB_BORDER_COLOR As String = "rgb(182, 170, 166)"
Public Const COLHDR_BCKGRND_COLOR As String = "rgb(0, 0, 0)"
Public Const ROWHDR_FONT_COLOR As String = "rgb(32, 17, 22)"
Public Const csHEADER_COLOR As String = "rgb(255, 255, 255)"
Public Const csROW_BACK As String = "rgb(255, 255, 255)"
#Else
Public Const TB_BORDER_COLOR As String = "#B6AAA6"
Public Const COLHDR_BCKGRND_COLOR As String = "#000000"
Public Const ROWHDR_FONT_COLOR As String = "#201116"
Public Const csHEADER_COLOR As String = "#FFFFFF"
Public Const csROW_BACK As String = "#FFFFFF"
#End If
Public Const ROWHDR_BCKGRND_COLOR As String = COLHDR_BCKGRND_COLOR
Public Const ROWHDR_BORDER_COLOR As String = TB_BORDER_COLOR
#Else
#If USE_RGB Then
Public Const TB_BORDER_COLOR As String = "rgb(182, 170, 166)"
Public Const COLHDR_BCKGRND_COLOR As String = "rgb(0, 0, 0)"
Public Const ROWHDR_FONT_COLOR As String = "rgb(32, 17, 22)"
Public Const csHEADER_COLOR As String = "rgb(255, 255, 255)"
Public Const csROW_BACK As String = "rgb(255, 255, 255)"
#Else
Public Const TB_BORDER_COLOR As String = "#B6AAA6"
Public Const COLHDR_BCKGRND_COLOR As String = "#000000"
Public Const ROWHDR_FONT_COLOR As String = "#201116"
Public Const csHEADER_COLOR As String = "#FFFFFF"
Public Const csROW_BACK As String = "#FFFFFF"
#End If
Public Const ROWHDR_BCKGRND_COLOR As String = COLHDR_BCKGRND_COLOR
Public Const ROWHDR_BORDER_COLOR As String = TB_BORDER_COLOR
#End If


#If USE_RGB Then
Public Const TB_BCKGRND_COLOR As String = "rgb(255, 255, 255)"
Public Const TB_FONT_COLOR As String = "rgb(48, 34, 38)"
#Else
Public Const TB_BCKGRND_COLOR As String = "#FFFFFF"
Public Const TB_FONT_COLOR As String = "#302226"
#End If
Public Const TB_FONT_SIZE As String = "11pt"
Public Const TB_PADDING As String = "0.3em"
Public Const MAX_BRACKETS As Long = 100
Public Const MAX_ROWS As Long = 100
Public Const MAX_COL As Long = 100

Enum FormulaSettings
NotSet = -1
AllFormulas = 0
FirstCell = 1
FirstCellInColumn = 2
NoFormulas = 3
UserDefined = 4
End Enum


idiotic! code tags doesn't keep format :( after edit

hm, now it works, weird :confused:

[DocAElstein]

sandy mSettings:


Option Explicit

#If VBA7 Then
#If USE_RGB Then
Public Const TB_BORDER_COLOR As String = "rgb(182, 170, 166)"
Public Const COLHDR_BCKGRND_COLOR As String = "rgb(0, 0, 0)"
Public Const ROWHDR_FONT_COLOR As String = "rgb(32, 17, 22)"
Public Const csHEADER_COLOR As String = "rgb(255, 255, 255)"
Public Const csROW_BACK As String = "rgb(255, 255, 255)"
#Else
Public Const TB_BORDER_COLOR As String = "#B6AAA6"
Public Const COLHDR_BCKGRND_COLOR As String = "#000000"
Public Const ROWHDR_FONT_COLOR As String = "#201116"
Public Const csHEADER_COLOR As String = "#FFFFFF"
Public Const csROW_BACK As String = "#FFFFFF"
#End If
Public Const ROWHDR_BCKGRND_COLOR As String = COLHDR_BCKGRND_COLOR
Public Const ROWHDR_BORDER_COLOR As String = TB_BORDER_COLOR
#Else
#If USE_RGB Then
Public Const TB_BORDER_COLOR As String = "rgb(182, 170, 166)"
Public Const COLHDR_BCKGRND_COLOR As String = "rgb(0, 0, 0)"
Public Const ROWHDR_FONT_COLOR As String = "rgb(32, 17, 22)"
Public Const csHEADER_COLOR As String = "rgb(255, 255, 255)"
Public Const csROW_BACK As String = "rgb(255, 255, 255)"
#Else
Public Const TB_BORDER_COLOR As String = "#B6AAA6"
Public Const COLHDR_BCKGRND_COLOR As String = "#000000"
Public Const ROWHDR_FONT_COLOR As String = "#201116"
Public Const csHEADER_COLOR As String = "#FFFFFF"
Public Const csROW_BACK As String = "#FFFFFF"
#End If
Public Const ROWHDR_BCKGRND_COLOR As String = COLHDR_BCKGRND_COLOR
Public Const ROWHDR_BORDER_COLOR As String = TB_BORDER_COLOR
#End If


#If USE_RGB Then
Public Const TB_BCKGRND_COLOR As String = "rgb(255, 255, 255)"
Public Const TB_FONT_COLOR As String = "rgb(48, 34, 38)"
#Else
Public Const TB_BCKGRND_COLOR As String = "#FFFFFF"
Public Const TB_FONT_COLOR As String = "#302226"
#End If
Public Const TB_FONT_SIZE As String = "11pt"
Public Const TB_PADDING As String = "0.3em"
Public Const MAX_BRACKETS As Long = 100
Public Const MAX_ROWS As Long = 100
Public Const MAX_COL As Long = 100

Enum FormulaSettings
NotSet = -1
AllFormulas = 0
FirstCell = 1
FirstCellInColumn = 2
NoFormulas = 3
UserDefined = 4
End Enum



my old version mSettings:


Option Explicit



#If VBA7 Then
Public Const TB_BORDER_COLOR As String = "#BBB"
Public Const COLHDR_BCKGRND_COLOR As String = "#DAE7F5"
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 ROWHDR_BCKGRND_COLOR As String = "#E0E0F0"
Public Const ROWHDR_BORDER_COLOR As String = "#A6AAB6"
Public Const ROWHDR_FONT_COLOR As String = "#161120"
#End If


Public Const TB_BCKGRND_COLOR As String = "#FFFFFF"
Public Const TB_FONT_SIZE As String = "11pt"
Public Const TB_PADDING As String = "0.3em"
Public Const TB_FONT_COLOR As String = "#262230"
Public Const MAX_BRACKETS As Long = 100
Public Const MAX_ROWS As Long = 100
Public Const MAX_COL As Long = 100

Enum FormulaSettings
NotSet = -1
AllFormulas = 0
FirstCell = 1
FirstCellInColumn = 2
NoFormulas = 3
UserDefined = 4
End Enum



Conclusions..
it seems that the
csHEADER
is now in mSettings.

Good to know
:)

[sandy666]

but this is mSettings not mBBcode :)



A
B
C
D
E

1DateIDNameCompanyCountry


221/03/201816850307-6211Felix WeissSem LLPSierra Leone


318/04/201816300905-7245Maggy Z. CruzMalesuada Augue Corp.Tonga


402/08/201716910128-2987Melyssa HaleMi CorporationLiechtenstein


519/01/201816340924-6224Beau E. ColonUltrices Iaculis Odio CorporationKazakhstan


601/06/201816490821-7609Brenden RoachNulla Aliquet PCBotswana


723/04/201716590903-0263Ahmed U. JoynerNec Cursus LLPFiji


806/04/201916760811-7656Signe ReillySuspendisse Ac Metus LimitedUruguay


921/05/201716161112-9816Candice G. SotoEnim LimitedCape Verde


1006/08/201816301111-8365Casey N. RivasAmet LimitedNicaragua


1129/11/201816600616-1431Bevis WhitneyPharetra Nibh Aliquam LLPUkraine


1212/01/201916960108-3315Ralph D. AndrewsUltricies Ligula Corp.Angola


doesn't matter ... It works !!! :)

[DocAElstein]

Thanks for info...

and Welcome to Excel Fox !!!!





... idiotic! code tags doesn't keep format :( after edit
hm, now it works, weird :confused:
( There are a few problems occaisionally when a carriage return does not work and the code comes out as a long single line.
http://www.excelfox.com/forum/showthread.php/2077-BBCode-Table?highlight=code#post9639
. I am not quite sure why that is.
But generally there are very few forum software problems here at Excel Fox :) )

[sandy666]

;)