" & 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