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
Printable View
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
PHP Code:
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613' http://www.excelfox.com/forum/f13/bbcode-table-2077/Option ExplicitDeclare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096 Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String 'Const csHEADER_COLOR As String = """#FFFFFF""" Const csHEADER_COLOR As String = "black" 'Const csHEADER_BACK As String = "#888888" Const csHEADER_BACK As String = "powderblue" Const csROW_BACK As String = "#FFFFFF" Set BB_Range = Selection BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine 'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) 'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row Next BB_Cells BB_Code = BB_Code & "[/tr]" For Each BB_Row In BB_Range.Rows 'Row Numbers BB_Code = BB_Code & "[tr]" 'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine For Each BB_Cells In BB_Row.Cells If BB_Cells.FormatConditions.Count Then strFontColour = objColour(DisplayedColor(BB_Cells, False, False)) strBackColour = objColour(DisplayedColor(BB_Cells, True, False)) Else strFontColour = objColour(BB_Cells.Font.Color) strBackColour = objColour(BB_Cells.Interior.Color) End If strAlign = FontAlignment(BB_Cells) BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine Next BB_Cells BB_Code = BB_Code & "[/tr]" & vbNewLine Next BB_Row BB_Code = BB_Code & "[/table]" 'End of main table BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name. ClipBoard_SetData (BB_Code) Set BB_Range = NothingEnd Sub Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End WithEnd Function Private Function ClipBoard_SetData(MyString As String) Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End IfEnd Function Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _ Optional ReturnColorIndex As Long = True) As Long Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant Dim F As String, R As Range '//Original code is written by Rick Rothstein '//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/ If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument." CurrentCell = ActiveCell.Address(0, 0) For X = 1 To Cell.FormatConditions.Count With Cell.FormatConditions(X) If .Type = xlCellValue Then Select Case .Operator Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2) Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2) Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value Case xlGreater: Test = Cell.Value > Evaluate(.Formula1) Case xlLess: Test = Cell.Value < Evaluate(.Formula1) Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1) Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1) End Select ElseIf .Type = xlExpression Then Application.ScreenUpdating = False 'Cell.Select F = Replace(.Formula1, "$", vbNullString) F = Replace(F, CurrentCell, Cell.Address(0, 0)) 'Test = Evaluate(.Formula1) Test = Evaluate(F) 'Range(CurrentCell).Select Application.ScreenUpdating = True End If If Test Then If CellInterior Then dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color) If IsNull(dColor) Then dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color) End If Else dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color) If IsNull(dColor) Then dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color) End If End If DisplayedColor = dColor Exit Function End If End With Next If CellInterior Then dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color) Else dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color) End If DisplayedColor = dColor End Function'Private Function ExcelVersion() As String Dim temp As String
'On Error Resume Next#If Mac Then Select Case Val(Application.Version) Case 11: temp = "Excel 2004" Case 12: temp = "Excel 2008" ' this should NEVER happen! Case 14: temp = "Excel 2011" Case 15: temp = "vNext" Case Else: temp = "Unknown" End Select#Else Select Case Val(Application.Version) Case 9: temp = "Excel 2000" Case 10: temp = "Excel 2002" Case 11: temp = "Excel 2003" Case 12: temp = "Excel 2007" Case 14: temp = "Excel 2010" Case 15: temp = "Excel 2013" Case Else: temp = "Unknown" End Select#End If ExcelVersion = tempEnd Function''Private Function ColLtr(ByVal iCol As Long) As String' shg 2012' Good for any positive Long If iCol > 0 Then ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26) Else End IfEnd Function
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
https://www.eileenslounge.com/viewtopic.php?f=44&t=40455&p=313035#p313035
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312889#p312889
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312886#p312886
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312752#p312752
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312734#p312734
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312727#p312727
https://www.eileenslounge.com/viewtopic.php?f=18&t=40411&p=312724#p312724
https://www.eileenslounge.com/viewtopic.php?f=44&t=40374&p=312535#p312535
https://www.eileenslounge.com/viewtopic.php?p=312533#p312533
https://www.eileenslounge.com/viewtopic.php?f=44&t=40373&p=312499#p312499
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9xpn-GDkL3o
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=UgzlC5LBazG6SMDP4nl4AaABAg. 9zYoeePv8sZ9zYqog9KZ5B
https://www.youtube.com/watch?v=jTmVtPHtiTg&lc=Ugy_RiNN_kAqUvZ8W994AaABAg. 9xhyRrsUUOM9zYlZPKdOpm
https://www.youtube.com/channel/UCnxwq2aGJRbjOo_MO54oaHA
So I think as of Jan 2015, I have a collection of BB Code Generating Macros in
“MollyBBCodes.xlsm”
And I think I have tidied the File up a bit, such that all these codes work independently.. ( But I may have missed a shared function or two!! )
File:
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
http://www.excelforum.com/attachment...lybbcodes.xlsm
http://www.excelforum.com/developmen...ml#post4293889
http://www.excelfox.com/forum/f17/te...2079/#post9635
Sub ShowRangeToBBCFormRoryAForumTools()
Excel 2007
Row\Col G H 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
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
PHP Code:
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
Next BB_Cells
spare Post, may need later if the next ones work....:)
EDIT: It did work %O
so, as it worked.. To share:
So I have a Work around…… ( which I do not understand.. ) … to get a code with strings containing BB Code to come up ( in a php Window ) which can then be copied to a VB Editor Code Window. ( Normal copying to between BB Code Tags ( as well as simple copying to between php BB Code Tags ) does not work … (… for me… Poo! ) )
_1 ) I copy a few lines from any code from a php Window that does appear to look normal……
_2 ) I paste that code bit into a spare WORD document. ( I have WORD 2007 )
_2a ) I notice that the text appears to be nested in a light grey background….
_3 ) Somewhere in the middle of that code I hit ENTER to get a few empty lines
_4 ) I copy my code from the VB Editor into the WORD document at the point of the spare lines I made
_4a) I notice that my code also appears to be nested in a light grey background.
_5 ) I now copy that into a php Window in a Thread post ( To do that I either; hit the php icon in the symbol in the Forum Editor and paste my code into the php BB Code Tag pair which appears; or paste in my code, highlight it and hit the hit the php icon in above in the symbol ribbon in the Forum Editor. )
First Declaring Bit of my Code version of the code from Pike, Kris and Rick.
PHP Code:
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
'
Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Main Code
PHP Code:
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table]"
'End of main table
BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Some required Functions
PHP Code:
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 http://www.excelfox.com/forum/f13/summary-of-maximum-rows-used-across-each-sheet-in-a-workbook-2053/#post9482
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
File with codes
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
Just some further Testing, as I may have another solution to the problem of codes pasted into a HTML ( or PHP ) Window "Loosing" a carriage return"
To remind ( me! ) of what i am testing out here: Sometimes it is better to use A HTML ( or PHP ) Code window rather than a BB Code Window to paste in a Forum Post. This can be the case, for example, when a Code itself contains text strings which may have BB Code Tags in. ( The Code tags usually are recognised as just that giving some peculiar results. )
This Code for example, shown here excactly as I want it, would get messed up in a code Window
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
End Sub
_................................................. ....
Pasted in a code Window:
You see the BB Code String was evaluated literally as BB Code. - The BB Code string is messed up as I do not wantCode: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
_.............................................
It is found that pasting in a HTML Code window instead can give you this
which is again what I wantedHTML Code:Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
End Sub
_...............................................
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.
. here the carriage retzurns have "vanished "HTML Code:Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"End Sub
_................................................. ..................................
_ I noticed and demonstrated that you can get over this sometimes by “doing a stop over “ in between at a a Word Document, that is to say pasting into a Word document first , then re – copying that to the clipboard and pasting that into the Forum Editor.
http://www.excelfox.com/forum/f17/te...2079/#post9641
http://www.excelfox.com/forum/f13/bb...2077/#post9645
_..............................................
OK that was one “workaround”..... _The other Day I had a similar problem (_.......... with a code i did to overcome the problem of the Forum Editor “eating” spaces of greater than two. )
http://www.eileenslounge.com/viewtop...art=20#p176255
_...............)
_ Some how this “loss of a carriage return crept in when pasted into a Post, ( even though in Word or in a displayed Message Box, the text i wanted to past in seemed OK ).
_ After a bit of experimenting I tried a modification which was basically this code line
= Replace((Text), vbCr, vbCr & vbLf, 1, -1) 'In Text~~,~~~replce a vbCr~~~,~~~with a vbCr & vbLf~~~~,~~~~the returned string should start at position 1 of the original ( so whole string returned )(Note: the number is not just where you start replacing- it is also where the returned String may start-so a number greater than 1 will "chop" bits off returning a string of reduced length compared with the original~~~,~~~-1~~indicates replace all occurrences
Writing a code to do something similar to the text held in the Clipboard appears to do something similar ( Not quite the same .. here what the Message box shows for the “Before” and “after” is different, which was not the case with the modification to the “preventing Forum editor eating spaces more than 2 codes” . Clearly the vbCr and vbLf is a trick one.. )
_.................
So Finally
_ If you wish to use the HTML Code Window rather than the BB Code Window when posting a Code in a Forum Thread.... you
_ Copy the code from the VB Editor, ( Ctrl C )
_ Run this code, ( which works on and modifies the text in the Clipboard.
Code:Sub PutInAvbLfInClipboadText() ' "Replcace vbCr with vbCr & vbLf "
'Get Current Text from Clipboard
Dim objDat As dataobject
Set objDat = New dataobject 'Set to a new Instance ( Blue Print ) of dataobject
'Dim obj As Object
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object instance of the Class.
Let TxtOut = objDat.GetText() 'retrieve the text in this instance of the Class. ( In this case all I have in it is the text typically I think as it is coming from a Ctrl C Copy from the VB Editor )
Dim originalClipboardText As String: Let originalClipboardText = TxtOut
Dim TextWithExtravbLF As String
Let TextWithExtravbLF = Replace(TxtOut, vbCr, vbCr & vbLf, 1, -1)
'Dump in Clipboard: This second instance of Data Object used to put in Clipboard
Dim objCliS As dataobject '**Early Binding. This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
Set objCliS = New dataobject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
' ( or instead of those two lines Dim obj As New DataObject ). or next two lines are.....Late Binding equivalent'
'Dim obj As Object' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objCliS.SetText TextWithExtravbLF 'Make Data object's text equal to a copy of ORefiginalText
objCliS.PutInClipboard 'Place current Data object into the Clipboard
' Get from clipboard. This a Another Object from class to be sure we have the data in the Clipboard
MsgBox prompt:="You dumped in Clipboard originally this " & vbCr & TxtOut & vbCr & "and if you try to get it, you should get" & vbCr & TextWithExtravbLF & ""
' End clean up.
'TheEnd: ' ( Come here always, even on a unpredictable error )
Set objDat = Nothing ' Good practice... maybe....
Set objCliS = Nothing ' ....... http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring.html#post4414065
End Sub
_ Paste into the Forum Thread an enclose in HTML Code Tags..This comes out:
HTML Code:Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
End Sub
AlanPHP Code:
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
End Sub
Just some further Testing, as I may have another solution to the problem of codes pasted into a HTML ( or PHP ) Window "Loosing" a carriage return"
To remind ( me! ) of what i am testing out here: Sometimes it is better to use A HTML ( or PHP ) Code window rather than a BB Code Window to paste in a Forum Post. This can be the case, for example, when a Code itself contains text strings which may have BB Code Tags in. ( The Code tags usually are recognised as just that giving some peculiar results. )
This Code for example, shown here excactly as I want it, would get messed up in a code Window
Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
End Sub
_................................................. ....
Pasted in a code Window:
You see the BB Code String was evaluated literally as BB Code. - The BB Code string is messed up as I do not wantCode: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
_.............................................
It is found that pasting in a HTML Code window instead can give you this
which is again what I wantedHTML Code:Sub CodeLinesInHTMLWindowLoosingCarriageReturns()
1 'Line 1
2 'Line 2
3 'Line 3
4 Dim strBBCodeTag As String
5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"
End Sub
_...............................................
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.
. here the carriage returns have „vanished!!!!"HTML Code:Sub CodeLinesInHTMLWindowLoosingCarriageReturns()1 'Line 12 'Line 23 'Line 34 Dim strBBCodeTag As String5 Let strBBCodeTag = "[color=lightsalmon]A Text in Forum Post to come out Light Salmon in Color[/color]"End Sub
_................................................. ..................................
_ I noticed and demonstrated that you can get over this sometimes by "doing a stop over " in between at a a Word Document, that is to say pasting into a Word document first , then re
IE 11 HTML Tags
HTML Code:' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table][/size]"
'End of main table
BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
IE 11 PHP Tags
PHP Code:
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table][/size]"
'End of main table
BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
IE 11 BB Code Tags
Code:' Convert Excel range to BBCode Table - Page 2
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/te...2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/te...2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Convert Excel range to BBCode Table - Page 2
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "]
v
[COLOR=" & csHEADER_COLOR & "]Row\Col[/COLOR]
" & Split(BB_Cells.Address, "$")(1) & "
[COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR]
" & BB_Row.Row & "
" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
[/size]"
'End of main table
BB_Code = BB_Code & "
Sheet: " & BB_Range.Parent.Name & "
" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/te...2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 VBA Column Letter from Column Number. Explained.
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
Google Chrome
from
http://www.ozgrid.com/forum/showthre...613#post763613
Code:Option Explicit
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "
v
" & Split(BB_Cells.Address, "$")(1) & "
" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
"
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
Goto OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
Google Chrome from here
Convert Excel range to BBCode Table - Page 2
Code:Option ExplicitDeclare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "
v
" & Split(BB_Cells.Address, "$")(1) & "
" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
"
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
Goto OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
HTML Code:Option ExplicitDeclare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Public Const GHND = &H42
Public Const CF_TEXT = 1
Public Const MAXSIZE = 4096
Sub BB_Table_Clipboard()
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & "[tr]"
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table]"
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
Goto OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
IE 11
Code:' Convert Excel range to BBCode Table - Page 2
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/te...2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/te...2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ Convert Excel range to BBCode Table - Page 2
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "]
v
[COLOR=" & csHEADER_COLOR & "]Row\Col[/COLOR]
" & Split(BB_Cells.Address, "$")(1) & "
[COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR]
" & BB_Row.Row & "
" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
[/size]"
'End of main table
BB_Code = BB_Code & "
Sheet: " & BB_Range.Parent.Name & "
" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/te...2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 VBA Column Letter from Column Number. Explained.
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
IE11
HTML Code:' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table][/size]"
'End of main table
BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
IE 11
PHP Code:
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
Sub BB_Table_Clipboard_PikeFoxAlan() 'http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
If BB_Cells.FormatConditions.Count Then
strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
Else
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
End If
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table][/size]"
'End of main table
BB_Code = BB_Code & "[Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
Google Chrome
PikeCode
Code:Option Explicit' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "
v
" & Split(BB_Cells.Address, "$")(1) & "
" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
"
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
HTML Code:Option Explicit' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370'Copy the syntax in the "VB:" window below to a standard Module'Select the range in the worksheet to be converted'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As LongDeclare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As LongDeclare Function CloseClipboard Lib "User32" () As LongDeclare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As LongDeclare Function EmptyClipboard Lib "User32" () As LongDeclare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As LongDeclare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Const GHND = &H42Private Const CF_TEXT = 1Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370 Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine For Each BB_Cells In BB_Range.Rows(1).Cells strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0) BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine Next BB_Cells BB_Code = BB_Code & "[/tr]" For Each BB_Row In BB_Range.Rows BB_Code = BB_Code & "[tr]" BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine For Each BB_Cells In BB_Row.Cells strFontColour = objColour(BB_Cells.Font.Color) strBackColour = objColour(BB_Cells.Interior.Color) strAlign = FontAlignment(BB_Cells) BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine Next BB_Cells BB_Code = BB_Code & "[/tr]" & vbNewLine Next BB_Row BB_Code = BB_Code & "[/table]" ClipBoard_SetData (BB_Code) Set BB_Range = NothingEnd Sub
Private Function objColour(strCell As String) As String objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)End Function
Private Function FontAlignment(ByVal objCell As Object) As String With objCell Select Case .HorizontalAlignment Case xlLeft FontAlignment = "LEFT" Case xlRight FontAlignment = "RIGHT" Case xlCenter FontAlignment = "CENTER" Case Else Select Case VarType(.Value2) Case 8 FontAlignment = "LEFT" Case 10, 11 FontAlignment = "CENTER" Case Else FontAlignment = "RIGHT" End Select End Select End WithEnd Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this Dim hGlobalMemory As Long, lpGlobalMemory As Long Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) lpGlobalMemory = GlobalLock(hGlobalMemory) lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Could not unlock memory location. Copy aborted." GoTo OutOfHere2 End If If OpenClipboard(0&) = 0 Then MsgBox "Could not open the Clipboard. Copy aborted." Exit Function End If X = EmptyClipboard() hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Could not close Clipboard." End IfEnd Function
After running cod to put in vbCR
HTML Code:' http://www.eileenslounge.com/viewtopic.php?f=26&t=22603&start=20#p176255 http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9687 ( Manual Solution Alternative: http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9645 )
Sub PutInAvbLfInClipboadText() ' "Replcace vbCr with vbCr & vbLf "
'Get Current Text from Clipboard
Dim objDat As dataobject
Set objDat = New dataobject 'Set to a new Instance ( Blue Print ) of dataobject
'Dim obj As Object
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object instance of the Class.
Let TxtOut = objDat.GetText() 'retrieve the text in this instance of the Class. ( In this case all I have in it is the text typically I think as it is coming from a Ctrl C Copy from the VB Editor )
Dim originalClipboardText As String: Let originalClipboardText = TxtOut
Dim TextWithExtravbLF As String
Let TextWithExtravbLF = Replace(TxtOut, vbCr, vbCr & vbLf, 1, -1)
'Dump in Clipboard: This second instance of Data Object used to put in Clipboard
Dim objCliS As dataobject '**Early Binding. This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. So I name it CLIpboardSend. But it is a DataObject. It has the Methods I need to send text to the Clipboard
Set objCliS = New dataobject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
' ( or instead of those two lines Dim obj As New DataObject ). or next two lines are.....Late Binding equivalent'
'Dim obj As Object' Late Binding equivalent' If you declare a variable as Object, you are late binding it. http://excelmatters.com/2013/09/23/vba-references-and-early-binding-vs-late-binding/
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/late-bound-msforms-dataobject/
objCliS.SetText TextWithExtravbLF 'Make Data object's text equal to a copy of ORefiginalText
objCliS.PutInClipboard 'Place current Data object into the Clipboard
' Get from clipboard. This a Another Object from class to be sure we have the data in the Clipboard
MsgBox prompt:="You dumped in Clipboard originally this " & vbCr & TxtOut & vbCr & "and if you try to get it, you should get" & vbCr & TextWithExtravbLF & ""
' End clean up.
'TheEnd: ' ( Come here always, even on a unpredictable error )
Set objDat = Nothing ' Good practice... maybe....
Set objCliS = Nothing ' ....... http://www.mrexcel.com/forum/excel-questions/361246-vbnullstring.html#post4414065
End Sub
Code:Option Explicit' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
'http://www.excelforum.com/development-testing-forum/1122041-test-new-table-to-bb-code.html
'Pike http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
'Copy the syntax in the "VB:" window below to a standard Module
'Select the range in the worksheet to be converted
'Run the "BB_Table_Clipboard()" Marco to create the table in BBcode.
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
Sub BB_Table_Clipboard_Pike() 'http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763370#post763370
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Set BB_Range = Selection
BB_Code = "[table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
For Each BB_Cells In BB_Range.Rows(1).Cells
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows
BB_Code = BB_Code & "[tr]"
BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table]"
ClipBoard_SetData (BB_Code)
Set BB_Range = Nothing
End Sub
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String) 'Changed to private as evaryone is / was using this
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Code:v
" & Split(BB_Cells.Address, "$")(1) & "
" & BB_Row.Row & "
[COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR]
"
Code:Sub AlanHansClipboardTextGetFindReplace() 'Using the "Dialogue Find Replace" way.
Rem 1) Put Selected Text in Clipboard.
Dim objCliS As DataObject '**Early Binding. Object from the class MS Forms, This is for an Object from the class MS Forms. This will be a Data Object of what we "send" to the Clipboard. It has the Methods I need to send text to the Clipboard. I will use this to put Things in the Clipboard. Bringing things out I will do with another Data Object
Set objCliS = New DataObject '**Must enable Forms Library: In VB Editor do this: Tools -- References - scroll down to Microsoft Forms 2.0 Object Library -- put checkmark in. Note if you cannot find it try OR IF NOT THERE..you can add that manually: VBA Editor -- Tools -- References -- Browse -- and find FM20.DLL file under C:\WINDOWS\system32 and select it --> Open --> OK.
' ( or instead of those two lines Dim obj As New DataObject which is the same ). or next two lines are...
'Dim objCliS As Object ' ...Late Binding equivalent'
'Set objCliS = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")' http://excelmatters.com/2013/10/04/l...ms-dataobject/
Dim Txtin As String: Let Txtin = Selection.Text: Debug.Print Txtin 'Copies the selection as a continuous string: Hit Ctrl G to see it in the Immediate window! You will see it with carriage returns , the Copmuter just sees it as a long "Horizontal" string
objCliS.SetText Txtin 'Make object's text equal above string variable
objCliS.PutInClipboard 'Place current object dataObject into the Clipboard ( Our original selected text ....!!!.... is in that )
'Rem 2) 'Bit of a bodge to get the text in a selection: create a Word file and paste to it
Dim FullFilePathAndFullName As String 'Initial Pigion Hole given for this String variable, and given a special vbNullString "Value", theoretically to simplify comparisons.
Documents.Add: ActiveDocument.Content.Paste 'Make a File Copy in current Application based on Default Type : And Paste from Clipoard ( ...!!!...our original selected text ) using the Default Copy which should at least have all the text, which is all we are interested in here.
ActiveDocument.SaveAs Filename:="TempBBCodeCopyTidledInSpaces.docx", FileFormat:=wdFormatXMLDocument 'Without this the document will not really "exist jet". It has a tempory name ( Used in Windows referrence ), but no path.
Let FullFilePathAndFullName = ActiveDocument.path & "\" & ActiveDocument.Name
Selection.WholeStory 'Selects whole document which here is just our selection of interest from the oroiginal document
'Rem 3) Han's Text Find Replacement Dialogue 'http://www.eileenslounge.com/viewtopic.php?f=26&t=22603#p175712
With Selection.Find 'This is the VBA code ( or very similar ) used by Excel when Using the Find eplace text Dialogue box. So this is an improved version of what a macro recording would give.
.ClearFormatting: .Replacement.ClearFormatting ' Don't use formatting, ? not sure this comes into the equation ??
.Wrap = wdFindStop ' Tell Word not to continue past the end of the selection ( And therefore prevents also a display Alert asking )
.MatchWildcards = False ' Don't use wildcards. The default anyway, but in this code is an important concept...
.Text = " " ' Search text is two spaces
.Replacement.Text = "~~" ' Replace text is with two tildas.
.Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
.Text = "~ " ' Search text is tilda followed by space
.Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
.Text = "~{1;}" 'or [~]{1;} It is still not totally clear whether this is a Reg Ex Pattern or a Wild Card String. Important is that it is a String in a Dialogue to be applied to A ( Word in this case ) document. Sort of as you write in a cell, so the ; , convention must be carefully checked and appropriately used here
.Replacement.Text = "^&" ' Enclose in BB codes ...... This "Wildcard" applies only to the Replace. It inserts the found string, or strings.
.MatchWildcards = True 'The next line does the Replce, here we are still selecting an option,( Use wildcards )
.Execute Replace:=wdReplaceAll ' Replace all within selection. This is the "OK" button!
End With
ActiveDocument.Select 'Re select the...( actually this line alone seems to do it )
Selection.WholeStory '...while document
Rem 4) "Reset the "Find Replace Text Dialogue" "Thing" "
With Selection.Find
.ClearFormatting: .Replacement.ClearFormatting: .Text = "": .Replacement.Text = "": .Forward = True: .Wrap = wdFindAsk: .Format = False: .MatchCase = False: .MatchWholeWord = False: .MatchKashida = False: .MatchDiacritics = False: .MatchAlefHamza = False: .MatchControl = False: .MatchWildcards = False: .MatchSoundsLike = False: .MatchAllWordForms = False '
End With
Rem 5) Final result to and from Clipboard
'5b) Using again objCliS we put the modified text in the Clipboard, so overwritng the original
objCliS.SetText Selection.Text 'Replace the text in the data object
objCliS.PutInClipboard 'Place current object dataObject into the Clipboard, so putting the modified text in there
'5b) Another data Object to get the data from the clipboard.
Dim objDat As DataObject
Set objDat = New DataObject 'Set to a new Instance ( Blue Print ) of dataobject
'Dim obj As Object
'Set obj = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
objDat.GetFromClipboard 'All that is in the Clipboard goes in this Data Object second instance of the Class.
Dim TxtOut As String: Let TxtOut = objDat.GetText() 'retrieve the text in this second instance of the Class. ( In this case all I have in it is the text )
MsgBox prompt:="You dumped in Clipboard this " & vbCr & objCliS.GetText() & vbCr & "and if you try to get it, you should get" & vbCr & TxtOut & ""
Rem 6) Optional to delete Temporary File
ActiveDocument.Close (wdDoNotSaveChanges) 'Giving the option will also prevent being asked for it. You must close. VBA will not let you kill an open sheet, as you are affectively working on a copy, and VBA is assumng the Original can be got at by saving for example. http://www.mrexcel.com/forum/excel-q...ml#post4425428
Kill FullFilePathAndFullName 'Use the Kill wisely!!!! - where this goes there 'aint no coming back!!
End Sub
Pike FontFartsWonks
http://www.excelfox.com/forum/showth...-BB-Code/page3
....there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list
Old:
Using Excel 2007
Row\Col F G14 PikeCalibri Fooaarrnst Arial Narrow 15 Verdana Batang _.................................................
Sheet: Molly
New Fonts
Using Excel 2007
Row\Col F G14 PikeCalibri Fooaarrnst Arial Narrow 15 Verdana Batang
Sheet: Molly
http://www.excelfox.com/forum/showth...=9801#post9801
Piike 16 may 2016
..........there you go font name added .. but will default if the worksheet font name is not avalibale in the forum BBcode font list.................................
Code:' To Copy this to a Forum Post you need Alan's HTML Text for copy in HTML Window Bodge Wonk http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9639
' http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
' http://www.excelfox.com/forum/f13/bbcode-table-2077/
' '//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
' No User Form. Run Main Code Sub BB_Table_Clipboard_PikeFoxAlan()
' PikeFoarnts 16th Mai 2016 --XX http://www.excelfox.com/forum/showthread.php/2077-BBCode-Table?p=9801#post9801
Option Explicit
' First Declaring Bit of my Code version of the code from Pike, Kris and Rick. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9642
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Declare Function CloseClipboard Lib "User32" () As Long
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "User32" () As Long
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, ByVal lpString2 As Any) As Long
Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Const GHND = &H42
Private Const CF_TEXT = 1
Private Const MAXSIZE = 4096
'
'Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643
Sub BB_Table_Clipboard_PikeFoarnts() ' http://www.excelfox.com/forum/f13/bbcode-table-2077/ http://www.ozgrid.com/forum/showthread.php?t=198172&page=2&p=763613#post763613
Dim BB_Row As Range, BB_Cells As Range, BB_Range As Range
Dim BB_Code As String, strFontColour As String, strBackColour As String, strAlign As String, strWidth As String
Dim strFontName As String ' --XX
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "powderblue"
Const csROW_BACK As String = "#FFFFFF"
Set BB_Range = Selection
BB_Code = "[color=lightgrey]Using " & ExcelVersion & "[/color]" & vbCrLf 'Give Excel version
BB_Code = BB_Code & "[size=" & 0 & "][table=" & """" & "class:thin_grid" & """" & "]" & vbNewLine
'BB_Code = BB_Code & "[tr][td][font=Wingdings]v[/font][/td]" & vbNewLine
BB_Code = BB_Code & "[tr=bgcolor:" & csHEADER_BACK & "][th][COLOR=" & csHEADER_COLOR & "][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th]" ' top left cell
For Each BB_Cells In BB_Range.Rows(1).Cells 'Column Letters
strWidth = Application.WorksheetFunction.RoundUp(BB_Cells.ColumnWidth * 7.5, 0)
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center, width:" & strWidth & """" & "][B]" & Split(BB_Cells.Address, "$")(1) & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[th][CENTER][COLOR=" & csHEADER_COLOR & "]" & ColLtr(BB_Cells.Column) & "[/COLOR][/CENTER][/th]" 'Column Letter Row
Next BB_Cells
BB_Code = BB_Code & "[/tr]"
For Each BB_Row In BB_Range.Rows 'Row Numbers
BB_Code = BB_Code & "[tr]"
'BB_Code = BB_Code & "[td=" & """" & "bgcolor:#ECF0F0, align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & csHEADER_BACK & ", align:center" & """" & "][B]" & BB_Row.Row & "[/B][/td]" & vbNewLine
For Each BB_Cells In BB_Row.Cells
' --XX If BB_Cells.FormatConditions.Count Then
' strFontColour = objColour(DisplayedColor(BB_Cells, False, False))
' strBackColour = objColour(DisplayedColor(BB_Cells, True, False))
' Else
' strFontColour = objColour(BB_Cells.Font.Color)
' strBackColour = objColour(BB_Cells.Interior.Color)
' End If
' strAlign = FontAlignment(BB_Cells)
' --XX BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/COLOR][/td]" & vbNewLine
strFontColour = objColour(BB_Cells.Font.Color)
strBackColour = objColour(BB_Cells.Interior.Color)
strAlign = FontAlignment(BB_Cells)
strFontName = BB_Cells.Font.Name
BB_Code = BB_Code & "[td=" & """" & "bgcolor:" & strBackColour & ", align:" & strAlign & """" & "][COLOR=""" & strFontColour & """][Font=""" & strFontName & """]" & IIf(BB_Cells.Font.Bold, "[B]", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "[/B]", "") & "[/Font][/COLOR][/td]" & vbNewLine
Next BB_Cells
BB_Code = BB_Code & "[/tr]" ' & vbNewLine
Next BB_Row
BB_Code = BB_Code & "[/table][/size]"
'End of main table
BB_Code = BB_Code & "[size=" & 0 & "][Table=""width:, class:grid""][tr][td]Sheet: [b]" & BB_Range.Parent.Name & "[/b][/td][/tr][/table][/size]" 'The parent ( One up the OOP change ) of the selects range is used to get at the sheet name.
ClipBoard_SetData (BB_Code)
BeepForPoo: Beep: Beep: Application.Wait (Now + TimeValue("0:00:01")): Beep
MsgBox prompt:="You Dumped in Clipboard!"
Beep: Beep: Beep: Beep: Application.Wait (Now + TimeValue("0:00:01")): Beep: Beep
Set BB_Range = Nothing
End Sub
'
'Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644
Private Function objColour(strCell As String) As String
objColour = "#" & Right(Right("000000" & Hex(strCell), 6), 2) & Mid(Right("000000" & Hex(strCell), 6), 3, 2) & Left(Right("000000" & Hex(strCell), 6), 2)
End Function
Private Function FontAlignment(ByVal objCell As Object) As String
With objCell
Select Case .HorizontalAlignment
Case xlLeft
FontAlignment = "LEFT"
Case xlRight
FontAlignment = "RIGHT"
Case xlCenter
FontAlignment = "CENTER"
Case Else
Select Case VarType(.Value2)
Case 8
FontAlignment = "LEFT"
Case 10, 11
FontAlignment = "CENTER"
Case Else
FontAlignment = "RIGHT"
End Select
End Select
End With
End Function
Private Function ClipBoard_SetData(MyString As String)
Dim hGlobalMemory As Long, lpGlobalMemory As Long
Dim hClipMemory As Long, X As Long
hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1)
lpGlobalMemory = GlobalLock(hGlobalMemory)
lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString)
If GlobalUnlock(hGlobalMemory) <> 0 Then
MsgBox "Could not unlock memory location. Copy aborted."
GoTo OutOfHere2
End If
If OpenClipboard(0&) = 0 Then
MsgBox "Could not open the Clipboard. Copy aborted."
Exit Function
End If
X = EmptyClipboard()
hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory)
OutOfHere2:
If CloseClipboard() = 0 Then
MsgBox "Could not close Clipboard."
End If
End Function
Private Function DisplayedColor(Cell As Range, Optional CellInterior As Boolean = True, _
Optional ReturnColorIndex As Long = True) As Long
Dim X As Long, Test As Boolean, CurrentCell As String, dColor As Variant
Dim F As String, R As Range
'//Original code is written by Rick Rothstein
'//http://www.excelfox.com/forum/f22/get-displayed-cell-color-whether-from-conditional-formatting-or-not-338/
If Cell.Count > 1 Then Err.Raise vbObjectError - 999, , "Only single cell references allowed for 1st argument."
CurrentCell = ActiveCell.Address(0, 0)
For X = 1 To Cell.FormatConditions.Count
With Cell.FormatConditions(X)
If .Type = xlCellValue Then
Select Case .Operator
Case xlBetween: Test = Cell.Value >= Evaluate(.Formula1) And Cell.Value <= Evaluate(.Formula2)
Case xlNotBetween: Test = Cell.Value <= Evaluate(.Formula1) Or Cell.Value >= Evaluate(.Formula2)
Case xlEqual: Test = Evaluate(.Formula1) = Cell.Value
Case xlNotEqual: Test = Evaluate(.Formula1) <> Cell.Value
Case xlGreater: Test = Cell.Value > Evaluate(.Formula1)
Case xlLess: Test = Cell.Value < Evaluate(.Formula1)
Case xlGreaterEqual: Test = Cell.Value >= Evaluate(.Formula1)
Case xlLessEqual: Test = Cell.Value <= Evaluate(.Formula1)
End Select
ElseIf .Type = xlExpression Then
Application.ScreenUpdating = False
'Cell.Select
F = Replace(.Formula1, "$", vbNullString)
F = Replace(F, CurrentCell, Cell.Address(0, 0))
'Test = Evaluate(.Formula1)
Test = Evaluate(F)
'Range(CurrentCell).Select
Application.ScreenUpdating = True
End If
If Test Then
If CellInterior Then
dColor = IIf(ReturnColorIndex, .Interior.ColorIndex, .Interior.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
End If
Else
dColor = IIf(ReturnColorIndex, .Font.ColorIndex, .Font.Color)
If IsNull(dColor) Then
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
End If
DisplayedColor = dColor
Exit Function
End If
End With
Next
If CellInterior Then
dColor = IIf(ReturnColorIndex, Cell.Interior.ColorIndex, Cell.Interior.Color)
Else
dColor = IIf(ReturnColorIndex, Cell.Font.ColorIndex, Cell.Font.Color)
End If
DisplayedColor = dColor
End Function
'
Private Function ExcelVersion() As String
Dim temp As String
'On Error Resume Next
#If Mac Then
Select Case Val(Application.Version)
Case 11: temp = "Excel 2004"
Case 12: temp = "Excel 2008" ' this should NEVER happen!
Case 14: temp = "Excel 2011"
Case 15: temp = "vNext"
Case Else: temp = "Unknown"
End Select
#Else
Select Case Val(Application.Version)
Case 9: temp = "Excel 2000"
Case 10: temp = "Excel 2002"
Case 11: temp = "Excel 2003"
Case 12: temp = "Excel 2007"
Case 14: temp = "Excel 2010"
Case 15: temp = "Excel 2013"
Case Else: temp = "Unknown"
End Select
#End If
ExcelVersion = temp
End Function
'
'
Private Function ColLtr(ByVal iCol As Long) As String
' shg 2012 Alan 2016 http://www.excelforum.com/tips-and-tutorials/1108643-vba-column-letter-from-column-number-explained.html
' Good for any positive Long
If iCol > 0 Then
ColLtr = ColLtr((iCol - 1) \ 26) & Chr(65 + (iCol - 1) Mod 26)
Else
End If
End Function
'Alan HTML Text for copy in HTML Window Bodge Wonk http://www.excelfox.com/forum/f13/bbcode-table-2077/#post9639
'_____________________________________________________________________________
ʅ_(ツ)_ʃ
__|
__|
Excel 2007 32 bit
got a new bit :rolleyes::rolleyes:
G H I 5Rory appears to 6be Playing with 7his Tool Today
Sheet: Molly
:rolleyes:
http://www.mrexcel.com/forum/about-b...ad-code-2.html
:rolleyes::rolleyes:
Using Excel 2007 32 bit
Row\Col G H I 5Rory appears to 6be Playing with 7his Tool Today
Molly
Edit has he lost his row abd column?
or did I
Excel 2007 32 bit
G H I 5Rory appears to 6be Playing with 7his Tool Today
Sheet: Molly
_......................................
For Info on Add-Ins see my signature and
http://www.excelforum.com/the-water-...ml#post4109080
. Hi.
Here are Some notes on an Add-In which allows you to paste a screenshot of a Spreadsheet range, in a form that we can copy to a Spreadsheet.
Here is the current Add-In from Rory Archibald, which he maintains and updates regularly
https://www.dropbox.com/s/31r9s6t9j6...ools.xlam?dl=0
Here are some Add-In versions of mine with minor modifications to the original above
https://app.box.com/s/oa1zouz1ksm68yevndee6yi1v1o0qmmm
https://app.box.com/s/7v5no8t18qqzjwyfqtv1xo5elsyba3o6
https://app.box.com/s/boxjrj2wmlren3tgqqnamzxknnpwyaut
…. I wrote some „Beginners type" Notes on how to get these Add-Ins working, referenced in my signature, again here the link:
https://app.box.com/s/gjpa8mk8ko4vkwcke3ig2w8z2wkfvrtv
. I am sure many Regulars do not need those notes, but possibly beginners like me wishing to use the Add-In may find them useful. Here they are given again below - Appologies that the images are in German. Hopefully the Pictures are still helpful in confirming the steps
A simple Code alternative from Pike is given here:
http://www.excelfox.com/forum/showth...=9805#post9805
Alan
P.s. For all codes, what you do is basically is
Highlight the range you wish to copy.
Copy it to the Clipboard ( Ctrl + C )
Paste in a Forum Post Editor.
It should then look like a lot of BB Code, but when posted it should come out as a Table.
Test here:
http://www.excelfox.com/forum/forumd...p/17-Test-Area
.................................................. ...................
[CENTER][U][B] Notes on Typical Download procedure for Forum Tool "Add
I often hit the post size character limit.
So every bit of saving of character usage is helpful to me
I often use Rory's Screenshot Tool.
I noticed it had a bit that for every row defined the background colour as white.
I took it out and it seems to have no effect on final output.
So that little change saves a bit of character space for me.
So:-
Taking out the “white background color”.
This is the default background row color, I think. It seems to come out at white anyway, so I took out the explicit “making it white bit”. In long deep tables that will save quite a few characters in the BB Code.
I did this, ‘cos I could ;)
So I did this simple Mod in the Private Function RngToBBC in the mBBCode Normal Code Module, (Basically I just edited out the bit in shown in red)
So it used to produce this:Code:'sOut = sOut & vbNewLine & "[tr=bgcolor:" & csROW_BACK & "]"
sOut = sOut & vbNewLine & "[tr]" 'Remove white background for entire row
If bHdr Then sOut = sOut & "[td=bgcolor:" & csHEADER_BACK & "][COLOR=" & csHEADER_COLOR & "]" & rRow.Row & "[/COLOR][/td]"
[color=lightgrey]Using Excel 2007 32 bit[/color]
[size=0][Table="width:, class:head"][tr=bgcolor:skyblue][th][COLOR=black][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th][th][CENTER][COLOR=black]J[/COLOR][/CENTER][/th][/tr]
[tr=bgcolor:#FFFFFF][td=bgcolor:skyblue][CENTER][COLOR=black][b]35[/b][/COLOR][/CENTER][/td][td][/td][/tr]
[/table][/size][size=0][color=lightgrey]Worksheet: [/color][b][color=darkblue]Intercepts[/b][/color][/size]
Using Excel 2007 32 bit
Worksheet: Intercepts
Row\Col J 35
After the small code mod I get this:
[color=lightgrey]Using Excel 2007 32 bit[/color]
[size=0][Table="width:, class:head"][tr=bgcolor:skyblue][th][COLOR=black][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th][th][CENTER][COLOR=black]F[/COLOR][/CENTER][/th][/tr]
[tr][td=bgcolor:skyblue][CENTER][COLOR=black][b]32[/b][/COLOR][/CENTER][/td][td][/td][/tr]
[/table][/size][size=0][color=lightgrey]Worksheet: [/color][b][color=darkblue]Intercepts[/b][/color][/size]
Using Excel 2007 32 bit
Worksheet: Intercepts
Row\Col F 32
This remains a jolly spiffing super Tool in my opinion. I have erected it in more places and more times than I care to remember. It really is the Doggies best :)
http://www.excelforum.com/showthread...=3#post4573121
http://www.excelfox.com/forum/showth...0055#post10055
http://excelmatters.com/excel-forums/#comment-199330
Get the Color shade you want to come out in Final Post
I expect there is a better way to do this, but I just hit on a way that works quite well, so I will document and share that now , and edit and update later if I come up with a more scientific and/ or automated way.
As an example , say I have seen this: _ shade _ somewhere, as you see it here, ( there ) . Lets assume I want to post that word in a Forum editor which accepts BB Code tags, ( BB Code tags: http://www.excelfox.com/forum/misc.php?do=bbcode ) such that I get that _ shade _ in the final post just as you see it here ( there )
Here is a way to do it:
_1 ) Use Word to get the shade of shade that you want,
__________________________________:rolleyes: :for example,
_ 1A) highlight any text and experiment with its color:
Word Text Color 0.JPG : https://imgur.com/xpCoo8B
Word Text Color 1 2.JPG : https://imgur.com/agdUo2f
Word Text Color 3.JPG : https://imgur.com/H5czlGV
Word Text Color 4.JPG : https://imgur.com/2ff71Xq
( Hit OK when finished to change selection color)
Attachment 1981Attachment 1982Attachment 1983Attachment 1984
_ 1B) As an alternative start point, you can find any text color anywhere, for example in the internet, paste into Word and adjust it in Word as per _ 1A)
_2 ) Copy the final Text to the clipboard.
Search the internet for any Word to HTML converter, there are many free ones available. Typically you can paste anything into a Visual Editor and then choose to obtain the HTML code
WordVisualToHTML.JPG : https://imgur.com/T19SMxG
Attachment 1980
_3 ) In the given HTML code will typically be some part referring to the text shade,_..
_.. here for example, the number of interest is _ color: #417394HTML Code:<p><span style="font-size: 11pt; line-height: 115%; font-family: Verdana, sans-serif; color: #417394;">shade</span></p>
_4 ) I assume the number used in the square bracket [ BB Code Color Tags ] pair is the same as in pointy bracket < HTML > code Tags color bit. It appears to be.
So for our example shade you would use this in a forum post_..
____ [color=#417394] shade [/color]
_.. which would come out like this:
__Scrol Tumy_____ shade
( If you want to keep the indent, as I did here (there), and avoid the forum editor “eating” spaces of more than one, ( as most forum editors do this ) ) , then use the white character trick: Post something like this:
[color=white]_ Any_White_Profanity Text [/color] [color=#417394] shade [/color]
Alan
DocAElstein
[color=#417394]
[B][u]DocAElstein[/u][/B][/color]
https://imgur.com/MKMjW0b
Ref
http://www.excelfox.com/forum/showth...plete-Document
https://imgur.com/MKMjW0b
http://www.excelfox.com/forum/misc.php?do=bbcode
https://wordtohtml.net/
http://services.runescape.com/m=foru...9,877,64690220
http://www.excelfox.com/forum/showth...age2#post10131
_.________________________________________________ _
Miscillanus Testies
Using Excel 2007 32 bit
Worksheet: Sheet1
Row\Col A 1 S No
[color=lightgrey]Using Excel 2007 32 bit[/color]
[size=0][Table="width:, class:head"][tr=bgcolor:#417394][th][COLOR=black][sub]Row[/sub]\[sup]Col[/sup][/COLOR][/th][th][CENTER][COLOR=black]A[/COLOR][/CENTER][/th][/tr]
[tr][td=bgcolor:#417394][CENTER][COLOR=black][b]1[/b][/COLOR][/CENTER][/td][td][CENTER][B]S No[/B][/CENTER][/td][/tr]
[/table][/size][size=0][color=lightgrey]Worksheet: [/color][b][color=darkblue]Sheet1[/b][/color][/size]
[s][/s]
== NO PARSE ==
[b]Unparsed[/b] [u]text[/u]
Snow
To Here: https://excelfox.com/forum/showthrea...ll=1#post10545
<p align=center style="font-family:'Verdana';font-size:11pt;color:blue;background:white"><span style="color:#0070C0"><u>Error and Error Handling VBA <b>Summary</b></u></span></p>
<table cellpadding="1px" rules="all" style=";background-color:#FFFFFF;border:1px solid;border-collapse:collapse; border-color: #A6AAB6"><colgroup><col width="25px" style="background-color:#E0E0F0"/>
<tr>
<td style="border:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:10pt">
<p align=center style="font-size:11pt;font-family:'Verdana'">Error Handling Code line <span style="color:white">ORNeRe_GoRoT_N0Nula_1_____<spa n>
</td>
<td style='border:solid windowtext 1.0pt;border-left:none;padding:0cm 3.5pt 0cm 3.5pt;height:10pt'>
<p align=center style="font-size:11pt;font-family:'Verdana'">Notes</p>
</td>
</tr>
<tr>
<td style="font-family:'courier new';font-size: 8pt;color:#0070C0;border:solid windowtext 1.0pt;border-top:none;padding:0cm 3.5pt 0cm 3.5pt;height:39.85pt">
<p style="font-size:8pt;font-family:'courier new';color:#0070C0"><span style="color:#0070C0">On Error Resume Next</span></p>
</td>
<td style='border-top:none;border-left:none;border-bottom:solid windowtext 1.0pt;border-right:solid windowtext 1.0pt;padding:0cm 3.5pt 0cm 3.5pt;height:39.85pt'>
<p align=left style="font-size:11pt;font-family:'Verdana'" >Makes code always carry on after error line. Clears the exception – So it works time and time again, <b>But</b> retains infomation of last error in Err object 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. Just goes to the indicated Label or Line Number (Typically at that label or line number would be code lines for an error handling routine ) It is Prevented by default ( due to it not clearing the exception ) from working more than once 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 !! Disables any enabled error handler 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 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) <b> Does not</b> disable any enabled error handler. Makes code try again at error line. ( Be careful as can lead to an infinite loop of retrying!) <b>Does not</b> retain infomation of last error: Clears <span style="font-family:'courier new'">Err</span> object 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. !! 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> <span style="font-family:'courier new'">.Clear</span> simply empties the string infomation Properties of <span style="font-family:'courier new'">Err</span></p>
<p style="font-family:'Verdana';font-size: 11pt"> <span style="font-family:'courier new'">Erl</span> : A Function or Method effectively returning line number of last error or 0 if no line number is present at erroring code line. It is possible this is just an old thing only working in the exception state to give the last excecuted line in the normal state. </p>
<p style="font-family:'Verdana';font-size: 11pt"> <span style="font-family:'courier new'">vbObjectError</span> : Probably broken or no one remembers what it does - A plie of wank - forget about it! </p>
For sandy....
I don't have the current newest version, but I think my old version is similar.....Quote:
where I can change color of the headers font in Forum Tool add-in?
Current: ( This is my version which I have already modified many times )
Using Excel 2007 32 bit
Worksheet: Tabelle1
Row\Col A B C 1Date Name Laps 2 05. AprDan 23
__ Alt+F11 (VB Editor Window)
__ 1 Forum Tools --- 2 Module --- 3 mBBCode
1 Forum Tools --- 2 Module --- 3 mBBCode.JPG : https://imgur.com/Rl95Bol
Attachment 2059
Code:Private Function RngToBBC(rInp As Range, _
iSize As Long, _
Optional bHdr As Boolean = True, _
Optional bFrm As Boolean = False, _
Optional bA1 As Boolean = False, _
Optional bColour As Boolean = False) As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
Const csHEADER_BACK As String = "#417394"
'Const csHEADER_BACK As String = "skyblue"
Const csROW_BACK As String = "#FFFFFF"
Dim sOut As String
Dim rRow As Range
Dim Cell As Range
_.________________-
Now Change to red for sandy...
Using Excel 2007 32 bit
Worksheet: Tabelle1
Row\Col A B 1Date Name 2 05. AprDan
_.______________________________________Code:Private Function RngToBBC(rInp As Range, _
iSize As Long, _
Optional bHdr As Boolean = True, _
Optional bFrm As Boolean = False, _
Optional bA1 As Boolean = False, _
Optional bColour As Boolean = False) As String
'Const csHEADER_COLOR As String = """#FFFFFF"""
Const csHEADER_COLOR As String = "black"
'Const csHEADER_BACK As String = "#888888"
'Const csHEADER_BACK As String = "#417394"
Const csHEADER_BACK As String = "red"
'Const csHEADER_BACK As String = "skyblue"
Const csROW_BACK As String = "#FFFFFF"
Dim sOut As String
Dim rRow As Range
Dim Cell As Range
Some test of mSettings code module
Using Excel 2007 32 bit
Worksheet: Tabelle1
Row\Col A B 1Date Name 2 05. AprDan
Using Excel 2007 32 bit
Worksheet: Tabelle1
Row\Col A B 1Date Name 2 05. AprDan
Using Excel 2007 32 bit
Worksheet: Tabelle1
Row\Col A B 1Date Name 2 05. AprDan
Using Excel 2007 32 bit
Worksheet: Tabelle1
Row\Col A B 1Date Name 2 05. AprDan
No changes in my old version
still no changes with this:
Using Excel 2007 32 bitCode:#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
Worksheet: Tabelle1
Row\Col A B 1Date Name 2 05. AprDan
new FT is a different but I found it here and it works
Code:#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:
sandy mSettings:
Code: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:
Code: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
:)
but this is mSettings not mBBcode :)
A B C D E 1Date ID Name Company Country 221/03/2018 16850307-6211 Felix Weiss Sem LLP Sierra Leone 318/04/2018 16300905-7245 Maggy Z. Cruz Malesuada Augue Corp. Tonga 402/08/2017 16910128-2987 Melyssa Hale Mi Corporation Liechtenstein 519/01/2018 16340924-6224 Beau E. Colon Ultrices Iaculis Odio Corporation Kazakhstan 601/06/2018 16490821-7609 Brenden Roach Nulla Aliquet PC Botswana 723/04/2017 16590903-0263 Ahmed U. Joyner Nec Cursus LLP Fiji 806/04/2019 16760811-7656 Signe Reilly Suspendisse Ac Metus Limited Uruguay 921/05/2017 16161112-9816 Candice G. Soto Enim Limited Cape Verde 1006/08/2018 16301111-8365 Casey N. Rivas Amet Limited Nicaragua 1129/11/2018 16600616-1431 Bevis Whitney Pharetra Nibh Aliquam LLP Ukraine 1212/01/2019 16960108-3315 Ralph D. Andrews Ultricies Ligula Corp. Angola
doesn't matter ... It works !!! :)
Thanks for info...
and Welcome to Excel Fox !!!!
( 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/showth...=code#post9639
. I am not quite sure why that is.
But generally there are very few forum software problems here at Excel Fox :) )
;)