Hi Doc,
I don't totally understand the question and it maybe better to post it in the help forum .. basically the code is VBA not PHP or HTML code.
Only post VBA with Code tags, PHP in the PHP tags and HTML code with HTML tags.
You should post a question on what you want to achieve and not your anticipated solution.
Hi Pike,
Thanks for the reply,
As far as I know that is usually the case, correct. But An exception is the codes we are looking at here which contain strings to build up a BB Code. Those strings will often interfere and cause problems when pasted within BB Code Tags. Hence we usually paste those codes in PHP or HTML ( If you heck out your post #1, you will see that :::.....Last edited by Admin; 01-20-2016 at 04:51 AM. Reason: replaced code tag with php ... . )Originally Posted by pike
I just did another quick demo for you:
First you see in BB Code Tags you get a problem:
http://www.excelforum.com/showthread...t=#post4376284
http://www.excelfox.com/forum/f17/te....html#post9720
Then the same in HTML Code Tags it is usually OK
http://www.excelforum.com/showthread...t=#post4376285
http://www.excelfox.com/forum/f17/te....html#post9718
and PHP Tags are also usually OK
http://www.excelfox.com/forum/f17/te....html#post9719
http://www.excelforum.com/showthread.php?t=1057943&page=13&p=4376284&highlight=#post4376326
Occaisionally, in some forums, some browsers etc. etc. you get the problem i was on about ....
http://www.excelfox.com/forum/f17/te...2079/#post9634
But I note that this Problem is appearing less and less. An update to the Forum Software may have had some effect
_....._________________________
I posted a small follow up question some time back, as there were problems with carriage returns vanishing sometimes when trying to copy and share the code further in the HTML Code tags. I had no answer.
I then found a couple of solutions to that problem myself so shared those.
So no Problem, Or rather I have given a couple of solution to a problem that can occur. ( Some people experienced the problem, contacted me and I sent them here to get the solution. In addition at another Forum they did something in their software to prevent the problem coming up ) - If you get the problem ever, then you can refer back to my detailed solutions, or let me know if you need better explanation. There were two general solutions, as I detailed in the previous post and in the referred to posts.
_..............
maybe better to post it in the help forum .
I think that would confuse the issue . The question and solution are directly related to using and, in particular sharing this code, so probably better to be tacked on here as I did. I realise that there should be no questions asked in this Sub Forum. But in this case I thought it was appropriate. .......... particularly as I gave then the solution.....
Anyone wanting the code will probably go straight to the first few posts here to get what they want. Then if they do experience the problems I detailed, then theymay come back here and they may see my reference to those problems and the given solutions. I do not think there is an "About the Board" Type Sub Forum here at ExcelFox. TheHelp Forums are for Excel Word, etc....
_..........................
I do not want to labor the point again as I have tried to explain it in detail. But very briefly.
_1) For these particular type of VBA Codes you do need to use HTML or PHP Code Tags when Posting them
_2) When you copy such a code into such Tags and post, you can sometimes get strange results as I indicated with carriage returns vanishing. I gave a couple of solutions to get over that.
Hope that clears it up a bit. Thanks for popping in here…. BTW.**
Alan
_..............................................
P.s. BTW**… How are you accessing ExcelFox just Now. Using Google Chrome I get blocked and am given a warning of a viruses , similar to those which plagued ExcelForum a few Months back. I would be carefuls how you access ExcelFox just now. I drop my Email to you per PM now as I am a bit nervous to use the Forum just now. I have informed Admin and Rick ( Rothstein )
_..
This is what I get when trying to Access ExcelFox using Google Chrome
:
For further examples see Links in first post here
http://www.excelforum.com/the-water-...e-or-back.html
Last edited by DocAElstein; 05-01-2016 at 05:52 PM.
Hello,
The PHP code is executed by the Web server when a web page is accessed and the resulting output is written as HTML within the Web page.
I just tried different PHPBB table properties to find which ones also worked with BBcode as the is little written about all there methods and properties.
Your question is about excel cell string which split string with carriage return[s] and converting to BBcode via VBA.
BBCode or Bulletin Board Code is a basic markup language used to format posts boards which is complied by HTML to covert to a basic table ect...
The VBA BBcode generator does not account for carriage returns in a cell .. work around .. .do not use carriage return and then size the columns and rows height and width to the desired look. Converting excel cell height and width to BBcode table (Height and Width) is a best fit as different fonts have different character heights and widths. basic algorithm for fifteen or so character (few Spaces) is RoundUp(BB_Cells.ColumnWidth * 7.5, 0) you will never get an exact conversion match. It is linear but also needs a count of different character sizes. a x potential algorithm could be better guess for 15 to 25 chars
Also not all excel font styles are available in BBcode so I never tried added them into the routine .. but you could do it and if the font is not available use a default. you will notice in the code above the Windings font does not always get complied from a v to an asteriskCode: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]"
It just a basic table and never a complete worksheet representation , if you have more a complex work upload a workbook.
hope that helps
Last edited by pike; 05-04-2016 at 12:20 PM.
Hi Pike,
I really do appreciate you taking the time to reply and give all of that info. It sounds very intersting. Thanks. Sadly , I am a computer novice, and do not really understand. I get only the general point. It certainly sounds like the code snippet you gave could come in handy to further improve your great BB Code Genarator Code. Sadly I lack the ability to incorporate that in your code. I lack the basic understanding. I do not really understand what you are talking about.......
...... No That was not anything like my question ( i think). You have given some fantasic answers but have completely missed my point. Sorry if i have explained so badly.....
I try again:
I did some more tests for you, just now to try to get accross what I am talking about. Once again: It is all to do with how to share your code in a Forum - that is to say what Code Tags to use. Your BB Code Genarator Code is a VBA Code, so normally we would use the normal BB Code Tags ( from icon # above ).....
But....
Basically the point is this:
-1) Your BB Code Genarator Code which is the point of this Thread ( and which is a VBA Code ) , will **usually not come out properly in a BB Code Window. So we use a HTML or PHP Code Window as an exception for this type of VBA Code, - that is to say a VBA Code where there are strings inside it with BB Code bits in it ( the square bracket stuff)
(_.. -2) Very occaisionally, ( and not often anymore ), there were also some additional problems when using a HTML window to post your BB Code Genarator Code. I gave a couple of work arounds to that. (Note that this post is from a few Month's ago and there were some updates in Forum Software in the maentime, effecting Code Windows, such as the scroll bar which suddenly appeared in many Forums that did not have it:
http://www.excelfox.com/forum/f17/code-tag-test-with-long-comments-1976/#post9664
from Post # 50 http://www.mrexcel.com/forum/about-b...sh-list-5.html
_.....)
What you are talkng about does sound very interseting and useful. But it is something completely different. ( i think
If you check out those tests I just did for you, then I think it should be obvious what I was getting at...
I am so very greatful that you take the time to give me such great ( unfortunately above my head partly ) info. So sorry it is not relavent to what I was trying to get across. Hope those extra tests will help.
Alan
_.........
**P.s. I note that in some of your referrences, for example
Convert Excel range to BBCode Table - Page 2
then in the code window you are using there, "VB:" , you do not experience the problems that I have been referring to. But as I have endeavoured to explain, you will get problems at MrExcel, ExcelFox, and ExcelForum if you attempt to post your VBA BBcode generator in normal BB Code Tags. It would appear that at Ozgrid your "normal" Code Window is different to that at MrExcel ExcelForum and ExcelFox. I have no account at, or experience with, Ozgrid Forum
_.....
P.P.s
Since the last time we spoke last January generally about BB Code Generators, the Theme came up a bit in some Threads.. may be just of passing interest...
How to post a range - headers and data? [SOLVED] - Page 17
Tags for Coloring Table cells for EXCELFORUM [SOLVED]
I updated the File I gave you, to include some of the new Codes presented.
https://app.box.com/s/zhz7awdag4nl1zs6564s9zzcwp50e4w9
Last edited by DocAElstein; 05-01-2016 at 08:33 PM.
I have posted the table on all the above forum with no problems.. attach the workbook with the offending strings
I think I am going mad...
It has nothing to do with Tables. A Workbook can be no help what so ever here.
Maybe you have not had time to read all the last few Posts I did for you?
Once again. I am talking about posting your code, ( or similar codes which within the code lines have BB Code Strings in them ) into a Forum Post.
I will repeat again what I have done for you all over the place in the links I gave in the last few posts above:
I will take a version of your code.
In the next post I will paste it in normal Code Tags.
Then in the Post after that I will post it again in HTML Code Tags
Then in the Post after that I will post it again in php Code Tags
These experiments i have done already for you in different Forums as linked in my las few replies
If you look carefully at the resulting codes you will see I think that in the Normal Code Tags there is some rubish in because the parts of the code with BB Code Tags strings in have interfered badly.
In the HTML and php Code windows the codes look fine.
The same I have found in other Forums. As I also mentioned it appears your normal code Tags are different at Ozgrid. You appear to not have this problem there. I cannot check that.
So .. experiments once again in next posts
EDIT And just for fun I dropped in a last one showing the other problem that only occasionally happens which is when carriage returns get lost
Maybe strangely you do not get the problem??
Why not try copying your code to the clipboard
Then paste it here in normal code Tags and see how it looks
Last edited by DocAElstein; 05-02-2016 at 02:18 PM.
Normal Code Tags
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 = "Using " & ExcelVersion & "" & vbCrLf 'Give Excel version BB_Code = BB_Code & "[size=" & 0 & "][/size]" 'End of main table BB_Code = BB_Code & "
v [COLOR=" & csHEADER_COLOR & "]Row\Col[/COLOR] " & Split(BB_Cells.Address, "$")(1) & " " & BB_Row.Row & " " & BB_Row.Row & " [COLOR=""" & strFontColour & """]" & IIf(BB_Cells.Font.Bold, "", "") & BB_Cells.Text & IIf(BB_Cells.Font.Bold, "", "") & "[/COLOR] " '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
Sheet: " & BB_Range.Parent.Name & "
HTML Code Tags
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
PHP 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
And just for fun the other problem that occaisionally occurs.. the loss of carriage returns
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/#post9642Declare 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''Main Code http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9643Sub 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 = NothingEnd Sub''Some required functions. http://www.excelfox.com/forum/f17/test-bb-code-2079/#post9644Private 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 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 IfEnd Function
Posting Permissions
Reply With Quote
Bookmarks