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, "OC")   'column and row headings with shading
  MsgBox "Xl2HTMLx ended"
End Sub
Sub XL2HTML()
  Call XL2HTML_Main(0, "OC")   '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) '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
   
    'Original coding and concept is based on
    '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
  'Planning -- revision possibilities:
  ' Plan. Multiple Areas from within the main subroutine,
  ' Plan.  -- might be useful for saving paper (snake columns)
  ' Plan.  ** might interfere with multiple sheets that is
  ' Plan.     setup to only process entire used ranges.
  ' Plan.  see coding in excel/join.htm#marksepareas  or merge.htm
 
    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
    Dim shadehd As String:
    shadehd = " bgcolor=""#d8d8d8"""
    Dim I As Long, iPos As Long
    Dim newx 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, "</head><body>"
     Print #1, "<!-- increasing cellpadding will make table bigger -->"
    End If
    
    Print #1, "<!-- ======================================= -->"
    Print #1, "<table border=""1"" bgcolor=""#FFFFFF""" _
        ; " cellspacing=""0"" cellpadding=""0"" align=""center"">"
    Dim urladdr As String
    Dim xStr As String
    Dim xColor As String, iColor As String
    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(Cells(1, c).AddressLocal(0, 0)) - 1) & "</td>"
      Next c
      x = x & "</tr>"
      Print #1, x
    End If

    For r = 1 To nr
        trStr = "<TR>"      'want to combine several lines
        'SHADING LINE ADDED...
        If shading = 1 Then _
          trStr = trStr & "<td" & shadehd & ">" & (Selection.Cells(r, 1).Row) & "</td>"

        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
            If Selection.Cells(r, c).HorizontalAlignment <> -4138 Then
              SSS = Selection.Cells(r, c).Text  'bug??? bypass
              If Trim(SSS) <> "" Then
                If Selection.Cells(r, c).HorizontalAlignment = -4108 Then
                   td = td & " align=""center"""
                ElseIf Selection.Cells(r, c).HorizontalAlignment = -4131 Then
                ElseIf Selection.Cells(r, c).HorizontalAlignment = -4152 Then
                   td = td & " align=""right"""
                ElseIf IsNumeric(Selection.Cells(r, c)) Then
                   td = td & " align=""right"""
                End If  ' not Blank and not spaces
              End If
            End If  '-4138 left, -4108 center, -4152 right, HTML default left
                        
            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 Selection.Cells(r, c).Font.Name
            Case "webdings", "Wingdings", "Wingdings 2", "Wingdings 3"
                xFontname = " face=""" & Selection.Cells(r, c).Font.Name & """"
            Case Else
                xFontname = ""
            End Select
            xColor = Right("000000" & Hex(Selection.Cells(r, c).Font.Color), 6)
            xColor = "#" & Right(xColor, 2) & Mid(xColor, 3, 2) & Left(xColor, 2)
            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 td = td & " BGCOLOR=""" & iColor & """"
            If Len(urladdr) > 0 Then  ' not = 0
               If Left(LCase(urladdr) & "        ", 7) <> "http://" Then
                   urladdr = "":  xColor = "#000000"  'back to black for email
               End If
            End If
            x = Selection.Cells(r, c).Text
            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 xColor = "#000000" Then
                 xColor = ""
              Else
                 xColor = " color=""" & xColor & """"
              End If
              If xColor & xFontname <> "" Then _
                 x = "<font" & xFontname & xColor & ">" & 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>"
               For I = iPos + 1 To Len(x)
                 If Mid(x, I, 1) = Chr(10) Then
                   newx = newx & "<br>"
                 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