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
'    Sub DelHyperLinks()
'       'David McRitchie
'       Selection.Hyperlinks.Delete
'    End Sub
    
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.

Sub XL2HTMLx()
  Call [personal.xls].XL2HTML_Main(1, "OCA")   'column and row headings with shading
  MsgBox "Xl2HTMLx ended"
End Sub
Sub XL2HTML()
  Call XL2HTML_Main(0, "OCA")   '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 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 codeon
    'http://www.herber.de/mailing/020598v.txt
    ' 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 <BR> 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
    'Planning -- revision possibilities:
    ' -- think everything that had been listed here was done
    ' -- styles
    ' -- Conditional formatting interior colors could be added
 
    Dim r%, c%
    Dim nr As Long, nC As Long
    Dim lastcell As Range
    'Dim xtra As Long
    'Dim filename As Variant
    'Dim shadehd As Variant
    Dim retval As Variant
    Dim x As String, xx 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 arrColor(0 To 2, 0 To 256) As String
    Dim arrAlign(0 To 256) As String
    Dim arrColorI(0 To 256) As String
    Dim ArrColorF(0 To 256) As String
    '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
    
    'iRows = Selection.Rows.Count
    'iColumns = Selection.Columns.Count
    'To Be Added: radio buttons, Row hdr, Col hdr, Shade hdr
    '  include suggested filename of c:\temp\XL2test.htm
    '(I include that file in my browsers bookmarks/favorites)
    
    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, "<html><head><meta NAME=""robots"" CONTENT=""noindex,nofollow"">"
     Print #1, "<!-- <style>TD  {font-family:arial; font-size: 11pt}</style> -->"
     Print #1, "<!-- <style>br {mso-data-placement:same-cell}  </style> -->"
     Print #1, "</head><body>"
     Print #1, "<!-- increasing cellpadding will make table bigger -->"
    End If
    
    Print #1, "<!-- ================== " _
       & Format(Now, "ddd yyyy-mm-dd hh:mm:ss") & " ============== -->"
    Print #1, "<table border=""1"" bgcolor=""#FFFFFF""" _
        ; " cellspacing=""0"" cellpadding=""0"" align=""center"">"
    Dim urladdr As String
    Dim xStr As String
    Dim fColor As String, iColor 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, "<tr align=""center""" & shadehd & ">"
      x = "<td>&nbsp</td>"
      For c = 1 To nC
         x = x & "<td>" & Left(Selection.Cells(1, c).AddressLocal(0, 0), _
            Len(Selection.Cells(1, c).AddressLocal(0, 0)) - 1) & "</td>"
      Next c
      x = x & "</tr>"
      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 = "<TR>"      'want to combine several lines
        For c = 1 To nC
            fColor = Right("000000" & Hex(Selection.Cells(r, c).Font.Color), 6)
            fColor = "#" & Right(fColor, 2) & Mid(fColor, 3, 2) & Left(fColor, 2)
            If fColor = "#000000" Then fColor = ""
            ArrColorF(c) = fColor
            iColor = Right("000000" & Hex(Selection.Cells(r, c).Interior.Color), 6)
            iColor = "#" & Right(iColor, 2) & Mid(iColor, 3, 2) & Left(iColor, 2)
            If iColor = "#FFFFFF" Then iColor = ""
            arrColorI(c) = iColor
            If c = 1 Then
                ArrColorF(0) = ArrColorF(1)
                arrColorI(0) = arrColorI(1)
            Else
               If fColor <> ArrColorF(0) Then ArrColorF(0) = ""
               If iColor <> arrColorI(0) Then arrColorI(0) = ""
            End If
            
            '---- alignment for row and cells ---
            arrAlign(c) = ""
            If Selection.Cells(r, c).HorizontalAlignment <> -4138 Then
                If Selection.Cells(r, c).HorizontalAlignment = -4108 Then
                   arrAlign(c) = "center"
                ElseIf Selection.Cells(r, c).HorizontalAlignment = -4131 Then
                ElseIf Selection.Cells(r, c).HorizontalAlignment = -4152 Then
                   arrAlign(c) = "right"
                ElseIf IsNumeric(Selection.Cells(r, c)) Then
                   arrAlign(c) = "right"
                End If  ' not Blank and not spaces
            End If  '-4138 left, -4108 center, -4152 right, HTML default left
            If c = 1 Then
               arrAlign(0) = arrAlign(1)
            ElseIf arrAlign(0) <> arrAlign(c) And Replace(" ", "", _
               Replace(Chr(160), "", Selection.Cells(r, c))) <> "" Then
               arrAlign(0) = ""
            End If
        Next c
        
        trStr = "<TR"
      ' If arrColorF(0) <> "" Then trStr _
      '     = trStr & " color=""" & arrColorF(0) & """"
        If arrColorI(0) <> "" Then trStr _
           = trStr & " bgcolor=""" & arrColorI(0) & """"
        If arrAlign(0) <> "" Then trStr _
           = trStr & " align=""" & arrAlign(0) & """"
        trStr = trStr & ">"
        '==================  TR processing completed ================
        
        'SHADING LINE ADDED...
        If shading = 1 Then
           If arrAlign(0) = "" Then x = "" Else x = " align=""left"""
           If Selection.Cells(r, 1).Row < 10 Then xx = Chr(160) Else xx = ""
           trStr = trStr & "<td" & x & shadehd & ">" _
                & xx & (Selection.Cells(r, 1).Row) & "</td>"
        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
            ' <THEAD><tr><th>...</tr></thead><TBODY><TBody><tr><td>...</td></tr></tbody>
            'If r = 1 Then TD = "TH": 'fix this up more if pages get support
            eTD = td
              
            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(0) = "" And 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 Application.Proper(Selection.Cells(r, c).Font.Name)
            Case "Monotype Sorts", "Webdings", "Wingdings", _
                "Wingdings 2", "Wingdings 3"
                xFontname = " face=""" & Selection.Cells(r, c).Font.Name & """"
            Case Else
                xFontname = ""
            End Select
            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
            
            fColor = ArrColorF(c) '.font.color
            If arrColorI(0) = "" And arrColorI(c) <> "" 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
            x = Selection.Cells(r, c).Text
            
            If arrAlign(c) = "" Then x = A160 & x
            If arrAlign(c) = "right" Then x = x & A160
            
            If Trim(x) = "" Then
               x = "&nbsp;"
            Else
              xStr = " " & LCase(Selection.Cells(r, c).Font.FontStyle) & " "
              If InStr(xStr, " bold ") Then _
                 x = "<b>" & x & "</b>"
              If InStr(xStr, " italic ") Then _
                 x = "<i>" & x & "</i>"
              If fColor <> "" Then xFontname = xFontname _
                 & " color=""" & fColor & """"
              If xFontname <> "" Then _
                 x = "<font" & xFontname & ">" & x & "</font>"
            End If
            If Len(urladdr) > 1 Then _
               x = "<a href=""" & urladdr & """>" & x & "</a>"
            iPos = InStr(1, x, Chr(10))
            If iPos > 0 Then
               newx = Left(x, iPos - 1) & "<br>" & A160
               For i = iPos + 1 To Len(x)
                 If Mid(x, i, 1) = Chr(10) Then
                   newx = newx & "<br>" & A160
                 Else
                   newx = newx & Mid(x, i, 1)
                 End If
               Next i
               x = newx
            End If
            x = "<" & td & ">" & x & "</" & eTD & ">"
            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
        Print #1, trStr & "</tr>"
    Next r

    Print #1, "</table>"
    If InStr(opt2, "T") Then Print #1, "<center><i><font size=""-2"">" & _
       "&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;" & _
       Format(Date + Time, "yyyy-mm-dd hh:mm") & "</i></font></center>"
    Print #1, "<! finished with " & ActiveSheet.Name & " >"
          
    If InStr(opt2, "C") Then
     'Print #1, "</body></html>"
      Print #1, "<!-- ============================================== -->"
      Close #1
      MsgBox "XL2HTML placed your HTML code in" & Chr(10) & filename
      ShellExecute 0, "open", filename, "", "", 0
    ElseIf InStr(opt2, "1") Then
      Close #1
    Else   'The follow would be used for multiple sheets
      Print #1, "<P>"
    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  <IMG src=""..."">", _
              "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, "<html><head><!base href=""" & MyFile_Str & """>"
     Print #1, "<meta NAME=""robots"" CONTENT=""noindex,nofollow""></head><body>"
more:
     Print #1, "<a href=""" & MyFile & """><img src = """ & MyFile & """ Width = ""100"" > "
     MyFile = Dir
     If MyFile <> "" Then GoTo more
     Print #1, "</body></html>"
     Close #1
     Shell "notepad " & filename
     'ShellExecute 0, "open", filename, "", "", 0
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, "<html><head><meta NAME=""robots"" CONTENT=""noindex,nofollow""></head><body>"
     Print #1, "<!-- increasing cellpadding will make table bigger -->"
    End If
    
    Print #1, "<!-- ======================================= -->"
    For r = 1 To nr
        trStr = ""
        For c = 1 To nC
            trStr = Selection.Cells(r, c).Text
            If Trim(trStr) = "" Then trStr = "&nbsp;"
        Next c
        Print #1, trStr
    Next r
    If InStr(opt2, "T") Then Print #1, "<center><i><font size=""-2"">" & _
       "&nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp; &nbsp;" & _
       Format(Date + Time, "yyyy-mm-dd hh:mm") & "</i></font></center>"
    Print #1, "<! finished with " & ActiveSheet.Name & " >"
     Shell "notepad " & filename
    '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(filename As String)
       ActiveCell.Activate
       ShellExecute 0, "open", filename, "", "", 0
End Sub