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
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
Last edited by DocAElstein; 03-16-2018 at 04:11 PM.
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.9zYoeePv8sZ9zYqog9KZ 5B
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg.9xhyRrsUUOM9zYlZPKdO pm
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
Last edited by DocAElstein; 03-01-2024 at 02:50 PM.
So I think as of Jan 2015, I have a collection of BB Code Generating Macros in
“MollyBBCodes.xlsm”
And I think I have tidied the File up a bit, such that all these codes work independently.. ( But I may have missed a shared function or two!! )
File:
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
http://www.excelforum.com/attachment...lybbcodes.xlsm
http://www.excelforum.com/developmen...ml#post4293889
http://www.excelfox.com/forum/f17/te...2079/#post9635
Sub ShowRangeToBBCFormRoryAForumTools()
Excel 2007
Row\Col G H 5Test Test Excel 2007
Sheet: Molly
Row\Col G H 5Test =G5
Sheet: Molly
Sub ShowRangeToBBCFormJune()
Using Excel 2007
Row\Col G H 5Test Test Using Excel 2007
Molly
Row\Col G H 5Test =G5
Molly
Sub ShowRangeToBBCFormSkyBlue()
Using Excel 2007
- G H 5Test Test Using Excel 2007
Molly
- 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
Last edited by DocAElstein; 01-20-2016 at 08:03 PM.
Using Excel 2007
Row\Col D E F G H I J K63 87 24 62 97 12 47 33 77 64 48 90 44 10 91 51 18 65 65 65 61 69 96 84 54 13 92 66 72 94 96 83 71 47 22 25 67 27 94 74 21 13 31 27 76 68 25 46 52 14 95 32 90 92 69 54 29 53 17 45 20 10 81 70 84 11 74 28 33 45 52 10 71 76 55 56 91 88 76 49 26 72 10 69 20 51 11 74 37 73 73 46 25 94 94 53 68 57 19 74 90 93 89 41 26 11 25 99 75 94 61 24 29 54 85 81 20
Sheet: Molly
Here a bit of my code:
_................................PHP Code:
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String 'Const csHEADER_COLOR As String = """#FFFFFF""" Const csHEADER_COLOR As String = "black" 'Const csHEADER_BACK As String = "#888888" Const csHEADER_BACK As String = "powderblue" Const csROW_BACK As String = "#FFFFFF" Set BB_Range = Selection BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine 'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) 'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row Next BB_Cells
Here a bit of Admin's code from Post #3
http://www.excelfox.com/forum/f13/bb...2077/#post9631
_........................PHP Code:
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
Next BB_Cells
But , the same code bit of Admin's copied first to my the VB Editor, and then back to a php window it does not work again….
PHP Code:
Sub BB_Table_Clipboard() Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String Set BB_Range = Selection BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine Next BB_Cells
Last edited by DocAElstein; 01-21-2016 at 08:34 PM.
spare Post, may need later if the next ones work....
EDIT: It did work
so, as it worked.. To share:
So I have a Work around…… ( which I do not understand.. ) … to get a code with strings containing BB Code to come up ( in a php Window ) which can then be copied to a VB Editor Code Window. ( Normal copying to between BB Code Tags ( as well as simple copying to between php BB Code Tags ) does not work … (… for me… Poo! ) )
_1 ) I copy a few lines from any code from a php Window that does appear to look normal……
_2 ) I paste that code bit into a spare WORD document. ( I have WORD 2007 )
_2a ) I notice that the text appears to be nested in a light grey background….
_3 ) Somewhere in the middle of that code I hit ENTER to get a few empty lines
_4 ) I copy my code from the VB Editor into the WORD document at the point of the spare lines I made
_4a) I notice that my code also appears to be nested in a light grey background.
_5 ) I now copy that into a php Window in a Thread post ( To do that I either; hit the php icon in the symbol in the Forum Editor and paste my code into the php BB Code Tag pair which appears; or paste in my code, highlight it and hit the hit the php icon in above in the symbol ribbon in the Forum Editor. )
Last edited by DocAElstein; 03-09-2016 at 04:45 PM.
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
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
Last edited by DocAElstein; 01-21-2016 at 09:05 PM.
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
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
File with codes
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
Bookmarks