-
test BB Code. Forum Tools. Forum Spreadsheet Screenshot Generator
-
PHP Code:
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613' http://www.excelfox.com/forum/f13/bbcode-table-2077/Option ExplicitDeclare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096 Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String 'Const csHEADER_COLOR As String = """#FFFFFF""" Const csHEADER_COLOR As String = "black" 'Const csHEADER_BACK As String = "#888888" Const csHEADER_BACK As String = "powderblue" Const csROW_BACK As String = "#FFFFFF" Set BB_Range = Selection BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine 'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) 'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row Next BB_Cells BB_Code = BB_Code & "[/tr]" For Each BB_Row In BB_Range.Rows 'Row Numbers BB_Code = BB_Code & "[tr]" 'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine For Each BB_Cells In BB_Row.Cells If BB_Cells.FormatConditions.Count Then strFontColour = objColour(DisplayedColor(BB_Cells, False, False)) strBackColour = objColour(DisplayedColor(BB_Cells, True, False)) Else strFontColour = objColour(BB_Cells.Font.Color) strBackColour = objColour(BB_Cells.Interior.Color) End If strAlign = FontAlignment(BB_Cells) BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine Next BB_Cells BB_Code = BB_Code & "[/tr]" & vbNewLine Next BB_Row BB_Code = BB_Code & "[/table]" 'End of main table BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name. ClipBoard_SetData (BB_Code) Set BB_Range = NothingEnd Sub Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End WithEnd Function Private Function ClipBoard_SetData(MyString As String) Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End IfEnd Function Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _ Optional ReturnColorIndex As Long = True) As Long Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant Dim F As String, R As Range '//Original code is written by Rick Rothstein '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/ If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument." CurrentCell = ActiveCell.Address(0, 0) For X = 1 To Cell.FormatConditions.Count With Cell.FormatConditions(X) If .Type = xlCellValue Then Select Case .Operator Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2) Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2) Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value Case xlGreater: Test = Cell.Value > Evaluate(.Formula1) Case xlLess: Test = Cell.Value < Evaluate(.Formula1) Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1) Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1) End Select ElseIf .Type = xlExpression Then Application.ScreenUpdating = False 'Cell.Select F = Replace(.Formula1, "$", vbNullString) F = Replace(F, CurrentCell, Cell.Address(0, 0)) 'Test = Evaluate(.Formula1) Test = Evaluate(F) 'Range(CurrentCell).Select Application.ScreenUpdating = True End If If Test Then If CellInterior Then dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color) If IsNull(dColor) Then dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color) End If Else dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color) If IsNull(dColor) Then dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color) End If End If DisplayedColor = dColor Exit Function End If End With Next If CellInterior Then dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color) Else dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color) End If DisplayedColor = dColor End Function'Private Function ExcelVersion() As String Dim temp As String
'On Error Resume Next#If Mac Then Select Case Val(Application.Version) Case 11: temp = "Excel 2004" Case 12: temp = "Excel 2008" ' this should NEVER happen! Case 14: temp = "Excel 2011" Case 15: temp = "vNext" Case Else: temp = "Unknown" End Select#Else Select Case Val(Application.Version) Case 9: temp = "Excel 2000" Case 10: temp = "Excel 2002" Case 11: temp = "Excel 2003" Case 12: temp = "Excel 2007" Case 14: temp = "Excel 2010" Case 15: temp = "Excel 2013" Case Else: temp = "Unknown" End Select#End If ExcelVersion = tempEnd Function''Private Function ColLtr(ByVal iCol As Long) As String' shg 2012' Good for any positive Long If iCol > 0 Then ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26) Else End IfEnd Function
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.eileenslounge.com/viewtopic.php?f=44&t=40455&p=313035#p313035
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312889#p312889
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312886#p312886
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312752#p312752
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312734#p312734
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312727#p312727
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724
https://www.eileenslounge.com/viewtopic.php?f=44&t=40374&p=312535#p312535
https://www.eileenslounge.com/viewtopic.php?p=312533#p312533
https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9xpn-GDkL3o
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg. 9zYoeePv8sZ9zYqog9KZ5B
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9zYlZPKdOpm
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
-
So I think as of Jan 2015, I have a collection of BB Code Generating Macros in
“MollyBBCodes.xlsm”
And I think I have tidied the File up a bit, such that all these codes work independently.. ( But I may have missed a shared function or two!! )
File:
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
http://www.excelforum.com/attachment...lybbcodes.xlsm
http://www.excelforum.com/developmen...ml#post4293889
http://www.excelfox.com/forum/f17/te...2079/#post9635
Sub ShowRangeToBBCFormRoryAForumTools()
Excel 2007
Excel 2007
Sub ShowRangeToBBCFormJune()
Using Excel 2007
Using Excel 2007
Sub ShowRangeToBBCFormSkyBlue()
Using Excel 2007
Using Excel 2007
Sub CopyRngToHTMLJBeaucaireBigMolly()
BigMolly
Sub CopyRngToBBCodeExcelForumLongThread()
Sub BB_Table_Clipboard_PikeAlan()
Using Excel 2007
Sub BB_Table_Clipboard_PikeFoxAlan()
Using Excel 2007
| Row\Col |
J |
K |
L |
|---|
| 5 |
Test |
ying |
"PikeFoxRick" |
| 6 |
Note |
does |
not |
| 7 |
have |
The |
XL2007 |
| 8 |
Cell |
Text |
Color |
| 9 |
problem |
that |
some |
| 10 |
similar |
codes |
have |
Alan
-
Using Excel 2007
| Row\Col |
D |
E |
F |
G |
H |
I |
J |
K |
|---|
| 63 |
87 |
24 |
62 |
97 |
12 |
47 |
33 |
77 |
| 64 |
48 |
90 |
44 |
10 |
91 |
51 |
18 |
65 |
| 65 |
65 |
61 |
69 |
96 |
84 |
54 |
13 |
92 |
| 66 |
72 |
94 |
96 |
83 |
71 |
47 |
22 |
25 |
| 67 |
27 |
94 |
74 |
21 |
13 |
31 |
27 |
76 |
| 68 |
25 |
46 |
52 |
14 |
95 |
32 |
90 |
92 |
| 69 |
54 |
29 |
53 |
17 |
45 |
20 |
10 |
81 |
| 70 |
84 |
11 |
74 |
28 |
33 |
45 |
52 |
10 |
| 71 |
76 |
55 |
56 |
91 |
88 |
76 |
49 |
26 |
| 72 |
10 |
69 |
20 |
51 |
11 |
74 |
37 |
73 |
| 73 |
46 |
25 |
94 |
94 |
53 |
68 |
57 |
19 |
| 74 |
90 |
93 |
89 |
41 |
26 |
11 |
25 |
99 |
| 75 |
94 |
61 |
24 |
29 |
54 |
85 |
81 |
20 |
Here a bit of my code:
PHP Code:
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String 'Const csHEADER_COLOR As String = """#FFFFFF""" Const csHEADER_COLOR As String = "black" 'Const csHEADER_BACK As String = "#888888" Const csHEADER_BACK As String = "powderblue" Const csROW_BACK As String = "#FFFFFF" Set BB_Range = Selection BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine 'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) 'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row Next BB_Cells
_................................
Here a bit of Admin's code from Post #3
http://www.excelfox.com/forum/f13/bb...2077/#post9631
PHP Code:
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
Next BB_Cells
_........................
But , the same code bit of Admin's copied first to my the VB Editor, and then back to a php window it does not work again….
PHP Code:
Sub BB_Table_Clipboard() Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String Set BB_Range = Selection BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine Next BB_Cells
-
PHP Code:
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
Next BB_Cells
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://eileenslounge.com/viewtopic.php?p=318868#p318868
https://eileenslounge.com/viewtopic.php?p=318311#p318311
https://eileenslounge.com/viewtopic.php?p=318302#p318302
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317704#p317704
https://eileenslounge.com/viewtopic.php?p=317857#p317857
https://eileenslounge.com/viewtopic.php?p=317541#p317541
https://eileenslounge.com/viewtopic.php?p=317520#p317520
https://eileenslounge.com/viewtopic.php?p=317510#p317510
https://eileenslounge.com/viewtopic.php?p=317547#p317547
https://eileenslounge.com/viewtopic.php?p=317573#p317573
https://eileenslounge.com/viewtopic.php?p=317574#p317574
https://eileenslounge.com/viewtopic.php?p=317582#p317582
https://eileenslounge.com/viewtopic.php?p=317583#p317583
https://eileenslounge.com/viewtopic.php?p=317605#p317605
https://eileenslounge.com/viewtopic.php?p=316935#p316935
https://eileenslounge.com/viewtopic.php?p=317030#p317030
https://eileenslounge.com/viewtopic.php?p=317030#p317030
https://eileenslounge.com/viewtopic.php?p=317014#p317014
https://eileenslounge.com/viewtopic.php?p=316940#p316940
https://eileenslounge.com/viewtopic.php?p=316927#p316927
https://eileenslounge.com/viewtopic.php?p=316875#p316875
https://eileenslounge.com/viewtopic.php?p=316704#p316704
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316412#p316412
https://eileenslounge.com/viewtopic.php?p=316254#p316254
https://eileenslounge.com/viewtopic.php?p=316046#p316046
https://eileenslounge.com/viewtopic.php?p=317050&sid=d7e077e50e904a138c794e1 f2115da95#p317050
https://www.youtube.com/@alanelston2330
https://www.youtube.com/watch?v=yXaYszT11CA&lc=UgxEjo0Di9-9cnl8UnZ4AaABAg.9XYLEH1OwDIA35HNIei0z-
https://eileenslounge.com/viewtopic.php?p=316154#p316154
https://www.youtube.com/watch?v=TW3l7PkSPD4&lc=UgwAL_Jrv7yg7WWC8x14AaABAg
https://teylyn.com/2017/03/21/dollarsigns/#comment-191
https://eileenslounge.com/viewtopic.php?p=317050#p317050
https://eileenslounge.com/viewtopic.php?f=27&t=40953&p=316854#p316854
https://www.eileenslounge.com/viewtopic.php?v=27&t=40953&p=316875#p316875
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
-
spare Post, may need later if the next ones work....:)
EDIT: It did work %O
so, as it worked.. To share:
So I have a Work around…… ( which I do not understand.. ) … to get a code with strings containing BB Code to come up ( in a php Window ) which can then be copied to a VB Editor Code Window. ( Normal copying to between BB Code Tags ( as well as simple copying to between php BB Code Tags ) does not work … (… for me… Poo! ) )
_1 ) I copy a few lines from any code from a php Window that does appear to look normal……
_2 ) I paste that code bit into a spare WORD document. ( I have WORD 2007 )
_2a ) I notice that the text appears to be nested in a light grey background….
_3 ) Somewhere in the middle of that code I hit ENTER to get a few empty lines
_4 ) I copy my code from the VB Editor into the WORD document at the point of the spare lines I made
_4a) I notice that my code also appears to be nested in a light grey background.
_5 ) I now copy that into a php Window in a Thread post ( To do that I either; hit the php icon in the symbol in the Forum Editor and paste my code into the php BB Code Tag pair which appears; or paste in my code, highlight it and hit the hit the php icon in above in the symbol ribbon in the Forum Editor. )
-
First Declaring Bit of my Code version of the code from Pike, Kris and Rick.
PHP Code:
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
'
Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
-
Main Code
PHP Code:
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table]"
'End of main table
BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
-
Some required Functions
PHP Code:
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 http://www.excelfox.com/forum/f13/summary-of-maximum-rows-used-across-each-sheet-in-a-workbook-2053/#post9482
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
-
