Option Explicit Declare Function ShellExecute Lib "Shell32.dll" _ Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal _ lpOperation As String, ByVal lpFile As _ String, ByVal lpParameters As String, _ ByVal lpDirectory As String, ByVal _ nShowCmd As Long) As Long Declare Function GetForegroundWindow Lib "user32" () As Long Public filename As String 'Omitted here because it is also in McRitchie_BuildTOC (buildtoc.htm) ' Sub DelHyperLinks() ' 'David McRitchie ' Selection.Hyperlinks.Delete ' End Sub ' documentation in http://www.mvps.org/dmcritchie/excel/xl2html.htm Sub spintest201() Dim cell As Range 'just testing For Each cell In Selection cell.Value = cell.MergeArea.Cells(1).Address _ & " " & cell.MergeArea.Columns.Count _ & " " & cell.MergeArea.Rows.Count Next cell End Sub Sub spintest202() Dim c As Long, r As Long For r = 1 To Selection.Rows.Count For c = 1 To Selection.Columns.Count If Selection.Cells(r, c).Address = _ Selection.Cells(r, c).MergeArea.Cells(1).Address Then Selection.Cells(r, c).Value = Selection.Cells(r, c).MergeArea.Cells(1).Address _ & " -- " & Selection.Cells(r, c).MergeArea.Columns.Count _ & " " & Selection.Cells(r, c).MergeArea.Rows.Count _ & " " & Selection.Cells(r, c).HorizontalAlignment End If Next c Next r End Sub 'DelHyperLinks, delete hyperlinks for selection ' suggested use on email addresses, if converting to HTML 'XL2HTML, Convert selection to HTML 'XL2HTMLx, Convert selection to HTML with row/column headers ' does not yet include color changes, etc. ' you may have to change "[pesonal.xls]." to your own repository ' as I may have forgotten to change the web copy from what I use ' i.e. "[personal.xls]." or remove it if in same library. Sub XL2HTMLx() Call [pesonal.xls].XL2HTML_Main(1, "OCAF") 'column and row headings with shading MsgBox "Xl2HTMLx ended" '-- F, though not used would be default to show Conditional Formatting if made an option End Sub Sub XL2HTML() Call XL2HTML_Main(0, "OCAF") 'default no column nor row headings End Sub Sub XL2HTMLa() 'David McRitchie 2003-02-09 Separate Areas based on marksepareas Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim i As Long, optFile As String Dim mareas As Range Set mareas = Selection MsgBox mareas.Address(0, 0) For i = 1 To mareas.Areas.Count mareas.Areas(i).Select optFile = "" If i = 1 Then optFile = "O" 'letter o If i = mareas.Areas.Count Then optFile = optFile & "C" Call XL2HTML_Main(1, optFile & "A") '0 no shading /1 shaded headers Next i mareas.Select Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub XL2HTMLm() 'David McRitchie 2003-11-22 Multiple areas w/o headers based on marksepareas Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Dim i As Long, optFile As String Dim mareas As Range Set mareas = Selection MsgBox mareas.Address(0, 0) For i = 1 To mareas.Areas.Count mareas.Areas(i).Select optFile = "" If i = 1 Then optFile = "O" 'letter o If i = mareas.Areas.Count Then optFile = optFile & "C" Call XL2HTML_Main(0, optFile & "A") '0 no shading /1 shaded headers Next i mareas.Select Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub Sub XL2HTMLs() 'Example: output multiple selected sheets... Dim optFile As String Dim shtcnt As Long Dim mshtCnt As Long Dim sht As Variant shtcnt = 0 mshtCnt = Application.ActiveWorkbook.Windows(1).SelectedSheets.Count For Each sht In Application.ActiveWorkbook.Windows(1).SelectedSheets Sheets(sht.Name).Select shtcnt = shtcnt + 1 optFile = "" If shtcnt = 1 Then optFile = "O" 'letter o If shtcnt = mshtCnt Then optFile = optFile & "C" Cells.Select Call XL2HTML_Main(0, optFile) Next sht End Sub Sub XL2HTML_Main(Optional shading As Long, _ Optional opt2 As String, _ Optional optOutputFile As String) 'O=open,C=Close,""=default, 1=special, T=Time, A=Align space 'Original coding and concept is based 28 lines of code ' formerly at http://www.herber.de/mailing/020598v.txt by ' Hans W. Herber * Microsoft Excel MVP 'Major changes D.McRitchie, 1998-08- msgbox, close, ' http://www.mvps.org/dmcritchie/excel/xl2htmlx.txt ' Shading option, Column & ROW headings and will use center justification ' when specifically formatted into Excel. 'Additional help Invoking IExplorer from VBA - ' From: "Chris Rae" posted Excel.programming 9Jun1999 'rev. 2000-06-25, hyperlinks for http:// (not email) ' Include Bold, Italic, Color (black for email) 'rev. 2000-07-01, handle merged cells (Rob Bruce), ' additional changes: center justification, ' multiple cells with TR "line", if fits in 80 bytes, ' XL2HTML_Main will be used by both XL2HTML and XL2HTMLx, ' center justification. Rev. 2000-07-02 added
for Chr(10) 'rev. 2000-07-03 for Center Across Selection (cell format) 'rev. 2001-08-11 multiple sheets, entire used content from each 'rev. 2001-08-11 for optional output dataset name in parameters 'rev. 2002-07-25 to right align numbers by default 'rev. 2002-08-24 to not right align empty cells 'rev. 2003-02-09 multiple areas (snake cols) see xl2HTMLa ' prob. not compatible with multiple sheets 'rev. 2003-09-06 TR align/bgcolor 'rev. 2003-09-07 Extra space for cells with A160, fix yesterday's alignment 'rev. 2003-09-25 TR align gets alignment required by majority in row 'rev. 2004-08-21 Change Shell invoking Internet Explorer 'rev. 2005-07-25 Cond Fmt added with "on error" and use of UCASE were needed. 'rev. 2005-07-26 fixed Cond Fmt based on Exce oddity (now my stuff will work) ' see http://www.j-walk.com/ss/excel/odd/odd07.htm ' also added bold and italic (additive) from either reg. or C.F. 'rev. 2005-12-30 addition of borders with css see my font.htm page ' must be MANUALLY SET or entered in InputBox see borders_wanted '---- 2005-12-31 minor revision for borders of the gray head col/rows 'rev. 2006-03-12 provide for cells larger than 1024 characters (.value instead of .text) 'rev. 2006-07-05 correction if lastcell is a merged cell 'Planning -- revision possibilities: ' -- think everything that had been listed here was done ' -- tore out all space saving interior color but that ' -- really wasn't the problem, may put it back in future, ' -- possibly using styles but probably won't bother Dim r%, c% Dim nr As Long, nC As Long, ir As Long, ic As Long Dim lastcell As Range Dim tRng As Range, tCell As String, AC As Long Dim retval As Variant Dim x As String, xx As String, TD_HD As String Dim A160 As String If InStr(opt2, "A") Then A160 = Chr(160) 'force left/rt space Dim shadehd As String: shadehd = " bgcolor=""#d8d8d8""" Dim i As Long, iPos As Long Dim newx As String Dim arrAlign(0 To 256) As String Dim rowAlignL As Long, rowAlignC As Long Dim rowAlignR As Long, rowAlignNA As Long Dim arrColorI(0 To 256) As String Dim ArrColorF(0 To 256) As String Dim ArrColorA(0 To 256) As String Dim TB As String 'for table borders will use embedded CSS style Dim borders_wanted As Boolean borders_wanted = False '2005-12-30 borders - InputBox may Change*** '-- if set to True you get individual cell borders in BLACK '-- if set to False border="1" like gridlines you can change output nr = Selection.Rows.Count nC = Selection.Columns.Count Set lastcell = Cells.SpecialCells(xlLastCell) If nr > lastcell.Row Then nr = lastcell.Row If nC > lastcell.Column Then nC = lastcell.Column 'check if lastcell is a merged cell in which case add '....Correction for nr and nC if it is a merged cell 2006-07-05 ir = Cells(nr, nC).Row - 1 + Cells(nr, nC).MergeArea.Rows.Count ic = Cells(nr, nC).Column - 1 + Cells(nr, nC).MergeArea.Columns.Count nr = ir nC = ic retry_filename: filename = "c:\temp\XL2test.htm" If optOutputFile <> "" Then filename = optOutputFile If InStr(opt2, "O") Then filename = InputBox("Supply filename for HTML generated from " _ & "selected range" & Chr(10) & Chr(10) _ & "Enter Borders for individual cell borders", _ "Filename for XL2HTML", filename) End If If Left(UCase(filename), 2) = "BO" Then borders_wanted = True GoTo retry_filename End If If InStr(opt2, "O") Or InStr(opt2, "1") Then Close #1 Open filename For Output As 1 End If If InStr(opt2, "O") Then If borders_wanted Then Print #1, "" Else Print #1, "" End If Print #1, "" Print #1, "" Print #1, "" Print #1, "" If borders_wanted Then '--shadehd = shadehd & " Class=""tb_HD""" Print #1, "" Print #1, "" Print #1, "" End If Print #1, "" Print #1, "" End If Print #1, "" If borders_wanted Then Print #1, "" Else Print #1, "
" End If Dim urladdr As String Dim xStr As String Dim iTypeSize As Long Dim td As String, eTD As String Dim xB As String Dim trStr As String Dim CenterAC As Long 'Center across Columns Dim xFontname As String Dim SSS As String If shading = 1 Then 'SHADING LINES ADDED... Print #1, "" If borders_wanted Then x = "" TD_HD = "" TD_HD = "" Next c x = x & "" Print #1, x End If For r = 1 To nr ArrColorF(0) = "" '-- initialize the column defaults arrColorI(0) = "" '-- each time a row is started arrAlign(0) = "" trStr = "" 'want to combine several lines rowAlignL = 0: rowAlignC = 0: rowAlignR = 0: rowAlignNA = 0 For c = 1 To nC Set tRng = Selection.Cells(r, c) tCell = tRng.Address(0, 0) AC = ActiveCondition(tRng) ArrColorF(c) = xColor(tRng, True, AC) arrColorI(c) = xColor(tRng, False, AC) ArrColorA(c) = tCell '---- alignment for row and cells --- '-- prior to Excel 2000 use Application.Substitute instead of Replace arrAlign(c) = "left" If Trim(Replace(tRng.Text, Chr(160), "")) = "" Then rowAlignNA = rowAlignNA + 1 arrAlign(c) = "" Else If Selection.Cells(r, c).HorizontalAlignment = -4138 Then arrAlign(c) = "left" rowAlignL = rowAlignL + 1 ElseIf Selection.Cells(r, c).HorizontalAlignment = -4108 Then arrAlign(c) = "center" rowAlignC = rowAlignC + 1 ElseIf Selection.Cells(r, c).HorizontalAlignment = -4131 Then arrAlign(c) = "left" rowAlignL = rowAlignL + 1 ElseIf Selection.Cells(r, c).HorizontalAlignment = -4152 Then arrAlign(c) = "right" rowAlignR = rowAlignR + 1 ElseIf IsNumeric(Selection.Cells(r, c)) Then arrAlign(c) = "right" rowAlignR = rowAlignR + 1 Else arrAlign(c) = "left" rowAlignL = rowAlignL + 1 End If ' not Blank and not spaces End If '-4138 left, -4108 center, -4152 right, HTML default left Next c trStr = " "#FFFFFF" Then trStr _ ' = trStr & " bgcolor=""" & arrColorI(1) & """" If rowAlignL >= rowAlignC And rowAlignL >= rowAlignR Then arrAlign(0) = "left" ElseIf rowAlignC >= rowAlignL And rowAlignC >= rowAlignR Then arrAlign(0) = "center" ElseIf rowAlignR >= rowAlignL And rowAlignR >= rowAlignC Then arrAlign(0) = "right" Else arrAlign(0) = "left" End If If arrAlign(0) <> "left" Then trStr _ = trStr & " align=""" & arrAlign(0) & """" trStr = trStr & ">" '================== TR processing completed ================ 'SHADING LINE ADDED... If shading = 1 Then If arrAlign(0) = "center" Then x = "" Else x = " align=""center""" If Selection.Cells(r, 1).Row < 10 Then xx = Chr(160) Else xx = "" trStr = trStr & "" _ & xx & (Selection.Cells(r, 1).Row) & "" End If For c = 1 To nC CenterAC = 0 'watch for Center Across Selection (Columns) 'numbers and text must be right aligned when generating HTML here If Selection.Cells(r, c).Address = _ Selection.Cells(r, c).MergeArea.Cells(1).Address Then '** secondary merged cells will not be processed ** td = "td" 'No special support for THEAD ' ' 'If r = 1 Then TD = "TH": 'fix this up more if pages get support eTD = td If borders_wanted Then TB = "" If Selection.Cells(r, c).Borders(xlEdgeLeft).LineStyle <> xlNone Then TB = TB & "L" If Selection.Cells(r, c).Borders(xlEdgeTop).LineStyle <> xlNone Then TB = TB & "T" If Selection.Cells(r, c).Borders(xlEdgeRight).LineStyle <> xlNone Then TB = TB & "R" If Selection.Cells(r, c).Borders(xlEdgeBottom).LineStyle <> xlNone Then TB = TB & "B" If TB <> "" Then td = td & " Class=""TB_" & TB & """" End If 'currently, If what would be the lower right cell is involved in a merged 'cell and that cell that would be the lower right cell is in fact the 'last cell (according to Excel) then there will be a problem. 'A way of bypassing the problem is to make sure the last cell is 'beyond your wanted range AND make a specific selection rather than 'simplly seleecting all cells. If Selection.Cells(r, c).MergeArea.Columns.Count > 1 Then _ td = td & " COLSPAN=""" & _ Selection.Cells(r, c).MergeArea.Columns.Count & """" If Selection.Cells(r, c).HorizontalAlignment = 7 Then For i = c + 1 To nC If IsEmpty(Selection.Cells(r, i)) Then If Selection.Cells(r, i).HorizontalAlignment = 7 Then CenterAC = CenterAC + 1 Else: i = nC End If Else i = nC End If Next i If CenterAC > 0 Then td = td & " COLSPAN=""" _ & CenterAC + 1 & """ ALIGN=""Center""" End If If Selection.Cells(r, c).MergeArea.Rows.Count > 1 Then _ td = td & " ROWSPAN=""" & _ Selection.Cells(r, c).MergeArea.Rows.Count & """" '--getting tiresome right aligning numbers will do automatically... '-- corrected 2002-08-24 // most of code move up with TR If arrAlign(c) <> "" Then If arrAlign(0) <> arrAlign(c) Then _ td = td & " align=""" & arrAlign(c) & """" urladdr = "" 'include hyperlinks but not =HYPERLINK() On Error Resume Next urladdr = Selection.Cells(r, c).Hyperlinks(1).Address ' If urladdr = "" Then urladdr = Application.URL(Selection.Cells(r, c)) On Error GoTo 0 Select Case StrConv(Selection.Cells(r, c).Font.Name, vbProperCase) Case "Monotype Sorts", "Symbol", "Webdings", "Wingdings", _ "Wingdings 2", "Wingdings 3" xFontname = " face=""" & Selection.Cells(r, c).Font.Name & """" Case Else xFontname = "" End Select If Selection.Cells(r, c).Font.Size <> "" Then iTypeSize = Selection.Cells(r, c).Font.Size If iTypeSize >= 12 Then If iTypeSize >= 28 Then xFontname = xFontname & " size=""+5""" ElseIf iTypeSize >= 24 Then xFontname = xFontname & " size=""+4""" ElseIf iTypeSize >= 18 Then xFontname = xFontname & " size=""+3""" ElseIf iTypeSize > 13.5 Then xFontname = xFontname & " size=""+2""" Else xFontname = xFontname & " size=""+1""" End If End If End If If arrColorI(c) <> "#FFFFFF" Then _ td = td & " BGCOLOR=""" & arrColorI(c) & """" ' If Len(urladdr) > 0 Then ' not = 0 ' If Left(LCase(urladdr) & " ", 7) <> "http://" Then ' urladdr = "": fColor = "#000000" 'back to black for email ' End If ' End If If Len(Selection.Cells(r, c).Text) > 1024 Then x = Selection.Cells(r, c).Value Else x = Selection.Cells(r, c).Text '-- normal End If '-- insert NBSP char(160) except for centered data '-- better than cellpadding which put white space horiz & vertically '-- don't want additional vertical spacing it spreads out height '-- and wastes paper If arrAlign(c) = "left" Then x = A160 & x If arrAlign(c) = "right" Then x = A160 & x & A160 If Trim(x) = "" Then x = Chr(160) '  is more obvious but wish to spare the bytes Else xStr = " " & LCase(Selection.Cells(r, c).Font.FontStyle) & " " If InStr(xStr, " bold ") Then _ x = "" & x & "" If InStr(xStr, " italic ") Then _ x = "" & x & "" If ArrColorF(c) <> "#000000" Then xFontname = xFontname _ & " color=""" & ArrColorF(c) & """" If xFontname <> "" Then _ x = "" & x & "" xStr = " " & LCase(Selection.Cells(r, c).Font.FontStyle) & " " '-- and if found in Conditional Formatting add these as well '-- not bothering with removal of duplicates If AC <> 0 Then On Error Resume Next '-- 2005-11-12 xStr = " " xStr = " " & _ LCase(Selection.Cells(r, c).FormatConditions(AC).Font.FontStyle) & " " On Error GoTo 0 If InStr(xStr, " bold ") Then _ x = "" & x & "" If InStr(xStr, " italic ") Then _ x = "" & x & "" End If End If If Len(urladdr) > 1 Then _ x = "" & x & "" iPos = InStr(1, x, Chr(10)) If iPos > 0 Then newx = Left(x, iPos - 1) & "
" & A160 For i = iPos + 1 To Len(x) If Mid(x, i, 1) = Chr(10) Then newx = newx & "
" & A160 Else newx = newx & Mid(x, i, 1) End If Next i x = newx End If x = "<" & td & ">" & x & "" If Len(trStr) + Len(x) > 80 Then If Len(trStr) > 0 Then Print #1, trStr trStr = "" End If End If trStr = trStr & x End If '* don't do secondary merged cells c = c + CenterAC Next c '-- correction for menus if column 2 has
--- If trStr = "" Then trStr = "" 'remove 2005-07-26 End If Print #1, trStr & "" Next r Print #1, "
 " shadehd = shadehd & " class=""tb_HD""" Else x = " " End If For c = 1 To nC 'td_hd is basically x = x & TD_HD & Left(Selection.Cells(1, c).AddressLocal(0, 0), _ Len(Selection.Cells(1, c).AddressLocal(0, 0)) - 1) & "
...
...
  
 
" End If '-- correction for caption= in second cell If Left(trStr, 18) = "" Then trStr = Selection.Cells(r, c).Text Else 'trStr = trStr & "
" If InStr(opt2, "T") Then Print #1, "
" & _ "                 " & _ Format(Date + Time, "yyyy-mm-dd hh:mm") & "
" Print #1, "" Print #1, "" If InStr(opt2, "C") Then 'Print #1, "" Print #1, "" Close #1 MsgBox "XL2HTML placed your HTML code in" & Chr(10) & filename ' typically -- c:\temp\xlstest.htm ' ShellExecute 0, "open", "c:\temp\xl2test.htm, "", "", 0 ' ShellExecute 0, "open", filename, "", "", 0 Dim RC As Long RC = Shell("Explorer " & filename, 1) '--also would work-- ActiveWorkbook.FollowHyperlink(filename) ElseIf InStr(opt2, "1") Then Close #1 Else 'The follow would be used for multiple sheets Print #1, "

" End If End Sub Sub pix() Dim MyFile, myPath, myName, filename, MyFile_Str As String MyFile_Str = InputBox("Provide directory with .jpg files" & Chr(10) _ & "for generating the SRC in ", _ "PIX: create HTML file for quick viewing", _ "c:\my documents\fdm_DC3200_pict\2001c\*.jpg") If MyFile_Str = "" Then Exit Sub filename = InputBox("provide full filename for output HTML file", _ "PIX: output file for create HTML File for quick viewing", _ "c:\temp\pix.htm") If MyFile_Str = "" Then Exit Sub MyFile = Dir(MyFile_Str, vbDirectory) Close #1 Open filename For Output As 1 Print #1, "" Print #1, "" more: Print #1, " " MyFile = Dir If MyFile <> "" Then GoTo more Print #1, "" Close #1 Dim RC As Long RC = Shell("Explorer " & filename, 1) End Sub Sub XL2HTMLQ() 'O=open,C=Close,""=default, 1=special, T=Time 'Based on ... ' http://www.mvps.org/dmcritchie/excel/xl2htmlx.txt Dim r%, c% Dim nr As Long, nC As Long Dim lastcell As Range Dim retval As Variant Dim i As Long, iPos As Long Dim newx As String Dim optOutputFile As String Dim opt2 As String Dim trStr As String Dim x As String opt2 = "O" 'Worksheets(1).Select nr = Selection.Rows.Count nC = Selection.Columns.Count Set lastcell = Cells.SpecialCells(xlLastCell) If nr > lastcell.Row Then nr = lastcell.Row If nC > lastcell.Column Then nC = lastcell.Column filename = "c:\temp\XL2test.htm" If optOutputFile <> "" Then filename = optOutputFile If InStr(opt2, "O") Then filename = InputBox("Supply filename for HTML generated from " _ & "selected range", "Filename for XL2HTML", filename) End If If InStr(opt2, "O") Or InStr(opt2, "1") Then Close #1 Open filename For Output As 1 End If If InStr(opt2, "O") Then Print #1, _ "" Print #1, "" End If Print #1, "" For r = 1 To nr trStr = "" For c = 1 To nC If Len(Selection.Cells(r, c).Value) > 1024 Then trStr = Selection.Cells(r, c).Value Else trStr = Selection.Cells(r, c).Text '-- normal End If If Trim(trStr) = "" Then trStr = " " Next c Print #1, trStr Next r If InStr(opt2, "T") Then Print #1, "

" & _ "                 " & _ Format(Date + Time, "yyyy-mm-dd hh:mm") & "
" Print #1, "" Shell "notepad " & filename Dim RC As Long RC = Shell("Explorer " & filename, 1) 'ShellExecute 0, "open", filename, "", "", 0 End Sub Function AntiSpam(Text, Optional optparm As String) 'change syz@syz.com to %73%79%7A%40%73%79%7A%2E%63%6F%6D Dim sOut As String, i As Long sOut = "" For i = 1 To Len(Text) If UCase(optparm) = "S" Then sOut = sOut & "&#" & Asc(Mid(Text, i, 1)) & ";" Else sOut = sOut & "%" & Hex(Asc(Mid(Text, i, 1))) End If Next AntiSpam = sOut End Function Sub OpenIE(Optional filename As String) ActiveCell.Activate If filename = "" Then filename = InputBox("supply name of file", _ "name", "c:\temp\xl2test.htm") If filename = "" Then Exit Sub End If Dim RC As Long RC = Shell("Explorer " & filename, 1) '--note filename has been set up as a public string variable End Sub Sub br_hide() Selection.Replace What:="
", _ replacement:=Chr(10), lookat:=xlPart, _ searchorder:=xlByRows, MatchCase:=False End Sub Sub br_unhide() Selection.Replace What:=Chr(10), _ replacement:="
", lookat:=xlPart, _ searchorder:=xlByRows, MatchCase:=False End Sub Function showAlign(cell As Range) As String 'David McRitchie, 2004-09-15 ' based on http://www.mvps.com/dmcritchie/excel/code/xl2htmlx.txt Dim ca As String '-- prior to Excel 2000 use Application.Substitute instead of Replace If Trim(Replace(cell.Text, Chr(160), "")) = "" Then ca = "N/A" ElseIf cell.HorizontalAlignment = -4138 Then ca = "Left" ElseIf cell.HorizontalAlignment = -4108 Then ca = "Center" ElseIf cell.HorizontalAlignment = -4131 Then ca = "Left" ElseIf cell.HorizontalAlignment = -4152 Then ca = "Right" ElseIf IsNumeric(cell) Then ca = "Right" Else ca = "Left" End If '-4138 left, -4108 center, -4152 right, HTML default left showAlign = ca End Function '-- prior to Excel 2000 use Application.Substitute instead of Replace Function xColor(rng As Range, OfText _ As Boolean, AC As Long) As String '-- D.McRitchie, 2005-07-25 extract colors using CP macros Dim ColorOfCF As Long If OfText = True Then ColorOfCF = 0 'rng.Item(1).Font.Color On Error Resume Next '2005-12-04 plain text in mixed colors ColorOfCF = rng.Font.Color On Error GoTo 0 Else ColorOfCF = rng.Interior.Color End If If AC > 0 Then If OfText = True Then On Error Resume Next ColorOfCF = rng.FormatConditions(AC).Font.Color Err.Clear Else On Error Resume Next ColorOfCF = rng.FormatConditions(AC).Interior.Color Err.Clear End If On Error GoTo 0 End If If OfText = True Then On Error Resume Next '2005-12-04 plain text in mixed colors If ColorOfCF = 0 Then ColorOfCF = rng.Font.Color Err.Clear Else If ColorOfCF = 16777215 Then ColorOfCF = rng.Interior.Color End If On Error GoTo 0 xColor = Right("000000" & Hex(ColorOfCF), 6) xColor = "#" & Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2) Dim tCell As String tCell = rng.Address(0, 0) End Function Function colorhex(fcolor As Long) As String colorhex = Right("000000" & Hex(fcolor), 6) colorhex = "#" & Right(colorhex, 2) & Mid(colorhex, 3, 2) & Left(colorhex, 2) End Function Sub achex(rng As Range) '-- D.McRitchie 2005-97-25 for testing use with dclick event Dim AC As Long Dim fcolor As String, iColor As String AC = ActiveCondition(rng) fcolor = xColor(rng, True, AC) iColor = xColor(rng, False, AC) MsgBox "AC=" & AC & Chr(10) _ & rng.Address(0, 0) & ": " & rng.Value & Chr(10) _ & "font " & fcolor & Chr(10) _ & "interior " & iColor & Chr(10) _ & "default formatting" & Chr(10) _ & "font: " & xColor(rng, True, 0) & Chr(10) _ & "interior: " & xColor(rng, False, 0) End Sub '------- invoked as a double-click macro --------- '-- Private Sub Worksheet_BeforeDoubleClick(ByVal _ '-- Target As Range, Cancel As Boolean) '-- Cancel = True '-- Application.Run "pesonal.xls!achex", Target '-- End Sub '-- /////////////////////////////////////////////// Function ActiveCondition(rng As Range) As Long '-- Chip Pearson's code to determine the Active Condition '-- http://www.cpearson.com/excel/CFColors.htm Dim Ndx As Long Dim FC As FormatCondition Dim Temp As Variant Dim Temp2 As Variant Dim tCell As String tCell = rng.Address(0, 0) If rng.FormatConditions.Count = 0 Then ActiveCondition = 0 Exit Function Else For Ndx = 1 To rng.FormatConditions.Count Set FC = rng.FormatConditions(Ndx) Select Case FC.Type Case xlCellValue Select Case FC.Operator Case xlBetween Temp = GetStrippedValue(FC.Formula1) Temp2 = GetStrippedValue(FC.Formula2) If IsNumeric(Temp) Then On Error GoTo nxt '-- Required If CDbl(rng.Value) >= CDbl(FC.Formula1) And _ CDbl(rng.Value) <= CDbl(FC.Formula2) Then ActiveCondition = Ndx Exit Function End If Else If UCase(rng.Value) >= UCase(Temp) And _ UCase(rng.Value) <= UCase(Temp2) Then ActiveCondition = Ndx Exit Function End If End If Case xlGreater Temp = GetStrippedValue(FC.Formula1) If IsNumeric(Temp) Then If CDbl(rng.Value) > CDbl(FC.Formula1) Then ActiveCondition = Ndx Exit Function End If Else If UCase(rng.Value) > UCase(Temp) Then ActiveCondition = Ndx Exit Function End If End If Case xlEqual Temp = GetStrippedValue(FC.Formula1) If IsNumeric(Temp) And IsNumeric(rng.Value) Then On Error GoTo nxt '-- Required If CDbl(rng.Value) = CDbl(FC.Formula1) Then ActiveCondition = Ndx Exit Function End If Else If UCase(Temp) = UCase(rng.Value) Then ActiveCondition = Ndx Exit Function End If End If Case xlGreaterEqual Temp = GetStrippedValue(FC.Formula1) If IsNumeric(Temp) Then If CDbl(rng.Value) >= CDbl(FC.Formula1) Then ActiveCondition = Ndx Exit Function End If Else If UCase(rng.Value) >= UCase(Temp) Then ActiveCondition = Ndx Exit Function End If End If Case xlLess Temp = GetStrippedValue(FC.Formula1) If IsNumeric(Temp) Then If CDbl(rng.Value) < CDbl(FC.Formula1) Then ActiveCondition = Ndx Exit Function End If Else If UCase(rng.Value) < UCase(Temp) Then ActiveCondition = Ndx Exit Function End If End If Case xlLessEqual Temp = GetStrippedValue(FC.Formula1) If IsNumeric(Temp) Then If CDbl(rng.Value) <= CDbl(FC.Formula1) Then ActiveCondition = Ndx Exit Function End If Else If UCase(rng.Value) <= UCase(Temp) Then ActiveCondition = Ndx Exit Function End If End If Case xlNotEqual Temp = GetStrippedValue(FC.Formula1) If IsNumeric(Temp) Then If CDbl(rng.Value) <> CDbl(FC.Formula1) Then ActiveCondition = Ndx Exit Function End If Else If UCase(Temp) <> UCase(rng.Value) Then ActiveCondition = Ndx Exit Function End If End If Case xlNotBetween Temp = GetStrippedValue(FC.Formula1) Temp2 = GetStrippedValue(FC.Formula2) If IsNumeric(Temp) Then If Not CDbl(rng.Value) <= CDbl(FC.Formula1) And _ CDbl(rng.Value) >= CDbl(FC.Formula2) Then ActiveCondition = Ndx Exit Function End If Else If Not rng.Value <= Temp And _ UCase(rng.Value) >= UCase(Temp2) Then ActiveCondition = Ndx Exit Function End If End If Case Else Debug.Print "UNKNOWN OPERATOR at " & rng.Address(0, 0) End Select Case xlExpression 'MAJOR Correction was Required here ' see http://www.j-walk.com/ss/excel/odd/odd07.htm ' cannot simply use Application.Evaluate(FC.Formula1) Dim F1 As String, F2 As String On Error GoTo x1ex_error F1 = Range(tCell).FormatConditions(Ndx).Formula1 F2 = Application.ConvertFormula(F1, xlA1, xlR1C1, , ActiveCell) F1 = Application.ConvertFormula(F2, xlR1C1, xlA1, , Range(tCell)) GoTo x1ex_continue x1ex_error: Debug.Print "x1exp -- " & rng.Address(0, 0) x1ex_continue: On Error GoTo 0 ' Debug.Print "x1exp_continue -- " & rng.Address(0, 0) & " - " & F1 ' On Error Resume Next If Application.Evaluate(F1) Then ActiveCondition = Ndx Exit Function End If Case Else Debug.Print "UNKNOWN TYPE at " & rng.Address(0, 0) End Select nxt: On Error GoTo 0 Next Ndx End If ActiveCondition = 0 End Function Function GetStrippedValue(CF As String) As String '-- Chip Pearson's code to determine the Active Condition '-- http://www.cpearson.com/excel/CFColors.htm Dim Temp As String If InStr(1, CF, "=", vbTextCompare) Then Temp = Mid(CF, 3, Len(CF) - 3) If Left(Temp, 1) = "=" Then Temp = Mid(Temp, 2) End If Else Temp = CF End If GetStrippedValue = Temp End Function