Here is the whole code. I declated it as string and it compiled ok. BTW, I didn't write it.
Sub SaveHTML97(strResultsFilepath As String)
' SaveHTML97 Macro
' Macro recorded 10/29/98 by An-Chian Kao
Dim objConvert(0) As Variant
Dim Result As Integer
Dim strHTMFilepath As String, strBasisFile As String
ThisWorkbook.Sheets("Reports").Activate
' make sure HTML.XLA is available
On Error Resume Next
AddIns("html").Installed = True
AddIns("Internet Assistant Wizard").Installed = True
On Error GoTo 0
ThisWorkbook.Activate
ThisWorkbook.Sheets("Reports").Activate
'Run the function
'sequence in htm is determined by array indexing
'Set this to a path appropriate for your system.
' do averages sheet
strBasisFile = "j:\avgbasis.html"
strHTMFilepath = "j:\average.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").Range("B39:F51")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
If intResult = htmlconvert_success Then
' turn off borders
strNewFile = Left(strHTMFilepath, Len(strHTMFilepath) - 1)
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<Table border>") > 0 Then
Print #2, "<Table border=""1"" cellpadding=""0"" cellspacing=""0"" COLS=5 WIDTH=""100%"">"
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
' Now fix yellow-ness
' color for yellow is #FFFF99
tmpBool = SetYellow("Rate the quality of the recommendations", "C41", "D41", "E41", "F41")
tmpBool = SetYellow("Rate the quality of the final", "C42", "D42", "E42", "F42")
tmpBool = SetYellow("How many disagreements", "C44", "D44", "E44", "F44")
tmpBool = SetYellow("How many differences", "C45", "D45", "E45", "F45")
tmpBool = SetYellow("How much personal friction", "C46", "D46", "E46", "F46")
tmpBool = SetYellow("How many personality", "C47", "D47", "E47", "F47")
tmpBool = SetYellow("How much did you enjoy", "C49", "D49", "E49", "F49")
tmpBool = SetYellow("How satisfied are you", "C50", "D50", "E50", "F50")
tmpBool = SetYellow("How comfortable would you feel", "C51", "D51", "E51", "F51")
Else
MsgBox "Error creating web page. Contact Village Software at 617-695-9332.", vbOKOnly
Exit Sub
End If
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' now fix widths/heights
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<TR") > 0 Then
strTemp = Left(strFileLine, 3) & " height=""45""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " height=""45"" width=""52%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""12%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""12%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""12%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""12%""" & Mid(strFileLine, 4)
Print #2, strTemp
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' top positives sheet
strBasisFile = "j:\basis.html"
strHTMFilepath = "J:\toppositive.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").Range("A69:G89")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
If intResult = htmlconvert_success Then
strNewFile = Left(strHTMFilepath, Len(strHTMFilepath) - 1)
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<Table border>") > 0 Then
Print #2, "<Table>"
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Else
MsgBox "Error creating web page. Contact Village Software at 617-695-9332.", vbOKOnly
Exit Sub
End If
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' now fix widths/heights
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<TR") > 0 Then
strTemp = Left(strFileLine, 3) & " height=""45""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #1
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " height=""45"" width=""1%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #2
Line Input #1, strFileLine
If InStr(strFileLine, "COLSPAN") > 0 Or InStr(strFileLine, "</TR") > 0 Then
If InStr(strFileLine, "</TR") > 0 Then
Print #2, strFileLine
Else
strTemp = Left(strFileLine, 3) & " width=""64%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
Else
strTemp = Left(strFileLine, 3) & " width=""48%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #3
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""1%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #4
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
' <td> #5
Line Input #1, strFileLine
If InStr(strFileLine, "COLSPAN") > 0 Or InStr(strFileLine, "</TR") > 0 Then
If InStr(strFileLine, "</TR") > 0 Then
Print #2, strFileLine
Else
strTemp = Left(strFileLine, 3) & " width=""35%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
Else
strTemp = Left(strFileLine, 3) & " width=""5%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #6
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #7
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' top negative sheet
strHTMFilepath = "J:\topnegative.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").Range("A95:G115")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
If intResult = htmlconvert_success Then
strNewFile = Left(strHTMFilepath, Len(strHTMFilepath) - 1)
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<Table border>") > 0 Then
Print #2, "<Table>"
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Else
MsgBox "Error creating web page. Contact Village Software at 617-695-9332.", vbOKOnly
Exit Sub
End If
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' now fix widths/heights
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<TR") > 0 Then
strTemp = Left(strFileLine, 3) & " height=""45""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #1
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " height=""45"" width=""1%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #2
Line Input #1, strFileLine
If InStr(strFileLine, "COLSPAN") > 0 Or InStr(strFileLine, "</TR") > 0 Then
If InStr(strFileLine, "</TR") > 0 Then
Print #2, strFileLine
Else
strTemp = Left(strFileLine, 3) & " width=""64%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
Else
strTemp = Left(strFileLine, 3) & " width=""48%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #3
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""1%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #4
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
' <td> #5
Line Input #1, strFileLine
If InStr(strFileLine, "COLSPAN") > 0 Or InStr(strFileLine, "</TR") > 0 Then
If InStr(strFileLine, "</TR") > 0 Then
Print #2, strFileLine
Else
strTemp = Left(strFileLine, 3) & " width=""35%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
Else
strTemp = Left(strFileLine, 3) & " width=""5%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #6
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
' <td> #7
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
End If
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' do cog vs aff chart
strHTMFilepath = "J:\affective.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").ChartObjects(4)
Kill ("j:\affective*.gif")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
' do gender chart
strHTMFilepath = "J:\gender.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").ChartObjects(1)
Kill ("j:\gender*.gif")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
' do nationality chart
strHTMFilepath = "J:\area.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").ChartObjects(2)
Kill ("j:\area*.gif")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
' do myers-briggs chart
strHTMFilepath = "J:\mb.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").ChartObjects(3)
Kill ("j:\mb*.gif")
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
' do totals sheet
strHTMFilepath = "J:\total.html"
Set objConvert(0) = ThisWorkbook.Sheets("Reports").Range("A130:G218")
' Kill (strHTMFilepath)
intResult = _
htmlconvert(objConvert, True, False, False, 1252, _
strHTMFilepath, existingfilepath:=strBasisFile, titlefullpage:="", _
headerfullpage:="", _
descriptionfullpage:="", _
linebeforetablefullpage:=True, lineaftertablefullpage:=True, _
lastupdate:="", namefullpage:="", _
EMailfullpage:="")
If intResult = htmlconvert_success Then
strNewFile = Left(strHTMFilepath, Len(strHTMFilepath) - 1)
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<Table border>") > 0 Then
Print #2, "<Table>"
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Else
MsgBox "Error creating web page. Contact Village Software at 617-695-9332.", vbOKOnly
Exit Sub
End If
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
' now fix widths/heights
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, "<TR") > 0 Then
strTemp = Left(strFileLine, 3) & " height=""45""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " height=""45"" width=""1%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""48%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""1%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""5%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
Line Input #1, strFileLine
strTemp = Left(strFileLine, 3) & " width=""15%""" & Mid(strFileLine, 4)
Print #2, strTemp
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
Kill (strResultsFilepath)
FileCopy "j:\forresults.html", strResultsFilepath
ThisWorkbook.FollowHyperlink Address:=strResultsFilepath
Erase objConvert
End Sub
Function SetYellow(strSearch As String, range1 As String, range2 As String, range3 As String, range4 As String) As Boolean
strHTMFilepath = "j:\average.htm"
strNewFile = "j:\averagetweak.html"
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
If InStr(strFileLine, strSearch) > 0 Then
Print #2, strFileLine
' cell 1
Line Input #1, strFileLine
strTest = "=" & ThisWorkbook.Sheets("Reports").Range(range1).Offset(0, 48).Address & "<$BA$2" 'FormatConditions.Item(1).Formula1
If Evaluate("='[DecisionEngine.xla]Reports'!" & (VBA.Mid(strTest, 2, VBA.InStr(strTest, "<") - 1)) & "'[DecisionEngine.xla]Reports'!" & VBA.Mid(strTest, VBA.InStr(strTest, "<") + 1)) Then
strFileLineNew = Left(strFileLine, 4) & "BGCOLOR=#FFFF99 " & Mid(strFileLine, 5)
Print #2, strFileLineNew
Else
Print #2, strFileLine
End If
' cell 2
Line Input #1, strFileLine
strTest = "=" & ThisWorkbook.Sheets("Reports").Range(range1).Offset(0, 48).Address & "<$BA$2" 'FormatConditions.Item(1).Formula1
If Evaluate("='[DecisionEngine.xla]Reports'!" & (VBA.Mid(strTest, 2, VBA.InStr(strTest, "<") - 1)) & "'[DecisionEngine.xla]Reports'!" & VBA.Mid(strTest, VBA.InStr(strTest, "<") + 1)) Then
strFileLineNew = Left(strFileLine, 4) & "BGCOLOR=#FFFF99 " & Mid(strFileLine, 5)
Print #2, strFileLineNew
Else
Print #2, strFileLine
End If
' cell 3
Line Input #1, strFileLine
strTest = "=" & ThisWorkbook.Sheets("Reports").Range(range1).Offset(0, 50).Address & "<$BA$2" 'FormatConditions.Item(1).Formula1
If Evaluate("='[DecisionEngine.xla]Reports'!" & (VBA.Mid(strTest, 2, VBA.InStr(strTest, "<") - 1)) & "'[DecisionEngine.xla]Reports'!" & VBA.Mid(strTest, VBA.InStr(strTest, "<") + 1)) Then
strFileLineNew = Left(strFileLine, 4) & "BGCOLOR=#FFFF99 " & Mid(strFileLine, 5)
Print #2, strFileLineNew
Else
Print #2, strFileLine
End If
' cell 4
Line Input #1, strFileLine
strTest = "=" & ThisWorkbook.Sheets("Reports").Range(range1).Offset(0, 50).Address & "<$BA$2" 'FormatConditions.Item(1).Formula1
If Evaluate("='[DecisionEngine.xla]Reports'!" & (VBA.Mid(strTest, 2, VBA.InStr(strTest, "<") - 1)) & "'[DecisionEngine.xla]Reports'!" & VBA.Mid(strTest, VBA.InStr(strTest, "<") + 1)) Then
strFileLineNew = Left(strFileLine, 4) & "BGCOLOR=#FFFF99 " & Mid(strFileLine, 5)
Print #2, strFileLineNew
Else
Print #2, strFileLine
End If
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
Kill (strHTMFilepath)
FileCopy strNewFile, strHTMFilepath
Kill (strNewFile)
SetYellow = True
End Function
Sub CorrectHTML(strFilename)
'This sub corrects the broken links in the HTML
Dim strNewFile As String
Dim strHTMFilepath As String
Dim strFileLine As String
Dim strFileLineMinusOne As String
Dim intCount As Integer
Dim strLeft As String
Dim strMId As String
strHTMFilepath = strFilename
'strHTMFilepath = ThisWorkbook.Path & "\results.html"
strNewFile = Left(strHTMFilepath, Len(strHTMFilepath) - 1)
Open strHTMFilepath For Input As #1
Open strNewFile For Output As #2
While Not EOF(1)
Line Input #1, strFileLine
' if we find the bad object
If InStr(strFileLine, "class=xl") > 0 Then
' let's make sure the same or following line have the appropriate string
strFileLineMinusOne = strFileLine
If InStr(strFileLine, "RANGE!") > 0 Then
If InStr(strFileLine, "#RANGE!") > 0 Then
Print #2, strFileLine
Else
' both class and range in the strFileLine. Fix it and move on.
'MsgBox strFileLine, , "Both same line"
'find where in the string the class=xl string is located
intCount = InStr(strFileLine, "class=xl")
'grab everything before class=xl
strLeft = Left(strFileLine, intCount - 1)
'grab everything after class=xl_______
strMId = Mid(strFileLine, intCount + 15)
'create new string without the class=xl stuff
strNewFileLine = strLeft & strMId
' write new string to file
Print #2, strNewFileLine ' should print new string here instead
End If
Else
Line Input #1, strFileLine
If InStr(strFileLine, "RANGE!") > 0 Then
If InStr(strFileLine, "#RANGE!") > 0 Then
Print #2, strFileLineMinusOne
Print #2, strFileLine
Else
' class and range on subsequent lines. Fix em and move on.
'MsgBox strFileLineMinusOne, , "class line"
'MsgBox strFileLine, , "range line"
intCount = InStr(strFileLineMinusOne, "class=xl")
strLeft = Left(strFileLineMinusOne, intCount - 1)
strMId = Mid(strFileLineMinusOne, intCount + 15)
strNewFileLine = strLeft & strMId
Print #2, strNewFileLine ' rebuilt with new class
Print #2, strFileLine ' save range line
End If
Else
' two lines don't have what we're looking for, write them out as received
Print #2, strFileLineMinusOne
Print #2, strFileLine
End If
End If
Else
Print #2, strFileLine
End If
Wend
Close #2
Close #1
End Sub