I am attempting to output a report to HTML. The problem I am having is that Access wants to force the output to multiple HTML files and I need it to be outputted to a single page HTML. I have searched and have not found many solutions to the issue, but I did find a piece of code that may help. I have pasted the code below. I am not a VBA programmer and I need to know how to get this to work in Access. BTW this is for a personal project that I am working on, it is a trading card database. Please let me know if you can help. Thanks
Here is John Lauer's code to do this. Works great.
Below is the code I wrote to do this. It is made up of 3 functions. The
first two (CombineHTMLFiles and CleanupHTMLFormatting) are generic and should
work for any report. The third (Fix_Subtotal_Alignment) was for a specific
alignment problem I had with my report, but I included it here for
completeness and since others may run into similar issues.
Important: To make this work correctly, you must also add some fields to the
reports which the code keys off of to do some of its replacements. (You can
see in the code below what they need to be, but an example is that you need
labels with the text "~HTML: insert HR here~" to make the code insert a <HR...
> tag in the HTML.) To prevent this text from appearing on the report in
Access, you will want to create the labels and then change the font color to
white so the text is "hidden" because it is the same color as the background
of the report. The horizontal positioning of these labels is not important
as long as they fall vertically between the rows of text where you want them.
(You can do a manual export to HTML and check the output HTML to insure they
fall exactly where you want them.)
Also, this uses both the MS Scripting library (for the FileSystemObject) and
VBScript Regular Expressions (for some of the search and replace), so you'll
have to add References to these libraries in your VBA project. The two
should appear in the list of available references as "Microsoft Scripting
Runtime" and "Microsoft VBScript Regular Expressions 5.x" (any 5.x version
will work, e.g. 5.5 or 5.6) if you have VBScript installed. (If not, you can
download it at (If you are not
familiar with setting References in the VBA editor, go to Tools - References
on the menu, find the ones you need in the list and check them, then click OK.
)
Okay, finally, here is the code...
First, here is the main function. You pass 3 parameters into it:
1) theFilename: the base of the filename (e.g. If Access has created files
called myreport.html and myreport_Page2.html, you will pass "myreport" into
the function)
2) Work_Folder: a temporary directory where you have had Access spit out
the html files, with a \ at the end (e.g. c:\myreport\work_directory\ )
3) Output_Folder: the final directory where you want the completed html
files, with a \ at the end (e.g. c:\myreport\final_output\ )
*** BEGIN CODE SAMPLE ***
Function CombineHTMLFiles(theFilename, Work_Folder, Output_Folder) As Integer
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim fsoFile
Dim checkForFiles As String
'the array below will be for the filenames - and the position in the
'array will be the file number used to open the file
' for the 2nd dim, position 1 is the file number and position 2 is the
actual file contents
Dim theFiles(1 To 99, 1 To 2) As String
Dim counter As Integer
counter = 1
checkForFiles = Dir(Trim(Work_Folder) & Trim(theFilename) & "*.html")
Do Until checkForFiles = ""
theFiles(counter, 1) = checkForFiles
Set fsoFile = fs
penTextFile(Trim(Work_Folder) & Trim(checkForFiles)
, ForReading)
theFiles(counter, 2) = fsoFile.ReadAll
fsoFile.Close
counter = counter + 1
'now try for another file
checkForFiles = Dir
Loop
Dim maxFile As Integer
maxFile = counter - 1
Dim outputFile As TextStream
Set outputFile = fso.CreateTextFile(Trim(Output_Folder) & Trim
(theFilename) & ".html", True)
If maxFile = 1 Then
'do the replaces to cleanup the output HTML formatting
'since Access doesn't save it to look real nice
'(note that this function returns the cleaned up HTML, so we set the
return
' of the function to the variable of the original HTML being sent in)
theFiles(1, 2) = CleanupHTMLFormatting(theFiles(1, 2))
'if there is only 1 file then we just write it out
outputFile.Write theFiles(1, 2)
Else
'if there are multiple files then we must parse and rejoin
'1st write out the first file without the closing tags
theFiles(1, 2) = CleanupHTMLFormatting(theFiles(1, 2))
outputFile.Write Left(theFiles(1, 2), (InStrRev(theFiles(1, 2),
"</TABLE>") + 9))
Dim startPos As Double, endPos As Double
'now do any remaining files, with just the actual body stuff
For counter = 2 To maxFile
startPos = InStr(theFiles(counter, 2), "<TABLE ") - 1
endPos = InStrRev(theFiles(counter, 2), "</TABLE>") + 8
theFiles(counter, 2) = CleanupHTMLFormatting(theFiles(counter, 2))
outputFile.Write Mid(theFiles(counter, 2), startPos, endPos -
startPos)
Next counter
'and finally add the closing tags
outputFile.Write "</BODY></HTML>"
End If
outputFile.Close
Set fso = Nothing
End Function
*** END CODE SAMPLE ***
Now here is the 2nd function. It is called from the first one
*** BEGIN CODE SAMPLE ***
Function CleanupHTMLFormatting(origHTML As String) As String
'first, change any ~HTML: insert HR here~ text to an actual HR tag
CleanupHTMLFormatting = Replace(origHTML, "~HTML: insert HR here~", "<HR
size=4 color=black width=100%>")
'now, change any ~HTML: insert blank line here~ text to a <BR> tag
CleanupHTMLFormatting = Replace(CleanupHTMLFormatting, "~HTML: insert
blank line here~", "<BR>")
'get rid of any <a href... tags since they are the Next Page, Prev Page,
etc links that we don't need
Dim myRegExp As RegExp
Set myRegExp = New RegExp
myRegExp.Pattern = "<a href.*</a>"
myRegExp.Global = True
myRegExp.IgnoreCase = True
myRegExp.Multiline = True
CleanupHTMLFormatting = myRegExp.Replace(CleanupHTMLFormatting, "")
Set myRegExp = Nothing
CleanupHTMLFormatting = Fix_Subtotal_Alignment(CleanupHTMLFormatting)
End Function
*** END CODE SAMPLE ***
*** BEGIN CODE SAMPLE ***
Function Fix_Subtotal_Alignment(theText)
Dim CRLF
CRLF = Chr(13) & Chr(10)
Dim startPos, endPos, startBlock, endBlock
Dim foreText, oldText, newText, postText
Dim objRegExpr, colMatches, objMatch
startPos = 1
Do While InStr(startPos, theText, "~HTML:start total row~") > 0
startPos = InStr(startPos, theText, "~HTML:start total row~")
endPos = InStr(startPos, theText, "~HTML:end total row~")
startBlock = InStrRev(theText, "<TABLE", startPos) - 1
endBlock = InStr(endPos, theText, "</TABLE>") + 8
foreText = Left(theText, startBlock - 1)
postText = Right(theText, (Len(theText) - endBlock))
oldText = Mid(theText, startBlock, (endBlock - startBlock))
Set objRegExpr = New RegExp
objRegExpr.Pattern = "COLOR=#000000>.*</FONT>"
objRegExpr.Global = True
objRegExpr.IgnoreCase = True
Set colMatches = objRegExpr.Execute(oldText)
newText = "<TABLE BORDER=0 CELLSPACING=0 CELLPADDING=0 >" & CRLF &
"<TR HEIGHT=14>" & CRLF
newText = newText & "<TD WIDTH=64 ALIGN=LEFT > <BR></TD><TD
WIDTH=500 ALIGN=RIGHT ><FONT style=FONT-SIZE:8pt FACE=""Arial""
COLOR=#000000>"
newText = newText & Mid(colMatches(0).Value, 15, Len(colMatches(0).
Value) - 21) & "</FONT></TD>" & CRLF
newText = newText & "<TD WIDTH=40 ALIGN=RIGHT ><FONT style=FONT-SIZE:
8pt FACE=""Arial"" COLOR=#000000>"
newText = newText & Mid(colMatches(1).Value, 15, Len(colMatches(0).
Value) - 21) & "</FONT></TD>" & CRLF
newText = newText & "<TD WIDTH=96 ALIGN=RIGHT ><FONT style=FONT-SIZE:
8pt FACE=""Arial"" COLOR=#000000>"
newText = newText & Mid(colMatches(2).Value, 15, Len(colMatches(0).
Value) - 21) & "</FONT></TD>" & CRLF
newText = newText & "</TR>" & CRLF & "</TABLE>" & CRLF
theText = foreText & newText & postText
startPos = startPos + 20
Set colMatches = Nothing
Set objRegExpr = Nothing
Loop
Fix_Subtotal_Alignment = theText
End Function
*** END CODE SAMPLE ***
Here is John Lauer's code to do this. Works great.
Below is the code I wrote to do this. It is made up of 3 functions. The
first two (CombineHTMLFiles and CleanupHTMLFormatting) are generic and should
work for any report. The third (Fix_Subtotal_Alignment) was for a specific
alignment problem I had with my report, but I included it here for
completeness and since others may run into similar issues.
Important: To make this work correctly, you must also add some fields to the
reports which the code keys off of to do some of its replacements. (You can
see in the code below what they need to be, but an example is that you need
labels with the text "~HTML: insert HR here~" to make the code insert a <HR...
> tag in the HTML.) To prevent this text from appearing on the report in
Access, you will want to create the labels and then change the font color to
white so the text is "hidden" because it is the same color as the background
of the report. The horizontal positioning of these labels is not important
as long as they fall vertically between the rows of text where you want them.
(You can do a manual export to HTML and check the output HTML to insure they
fall exactly where you want them.)
Also, this uses both the MS Scripting library (for the FileSystemObject) and
VBScript Regular Expressions (for some of the search and replace), so you'll
have to add References to these libraries in your VBA project. The two
should appear in the list of available references as "Microsoft Scripting
Runtime" and "Microsoft VBScript Regular Expressions 5.x" (any 5.x version
will work, e.g. 5.5 or 5.6) if you have VBScript installed. (If not, you can
download it at (If you are not
familiar with setting References in the VBA editor, go to Tools - References
on the menu, find the ones you need in the list and check them, then click OK.
)
Okay, finally, here is the code...
First, here is the main function. You pass 3 parameters into it:
1) theFilename: the base of the filename (e.g. If Access has created files
called myreport.html and myreport_Page2.html, you will pass "myreport" into
the function)
2) Work_Folder: a temporary directory where you have had Access spit out
the html files, with a \ at the end (e.g. c:\myreport\work_directory\ )
3) Output_Folder: the final directory where you want the completed html
files, with a \ at the end (e.g. c:\myreport\final_output\ )
*** BEGIN CODE SAMPLE ***
Function CombineHTMLFiles(theFilename, Work_Folder, Output_Folder) As Integer
Dim fso As Scripting.FileSystemObject
Set fso = New Scripting.FileSystemObject
Dim fsoFile
Dim checkForFiles As String
'the array below will be for the filenames - and the position in the
'array will be the file number used to open the file
' for the 2nd dim, position 1 is the file number and position 2 is the
actual file contents
Dim theFiles(1 To 99, 1 To 2) As String
Dim counter As Integer
counter = 1
checkForFiles = Dir(Trim(Work_Folder) & Trim(theFilename) & "*.html")
Do Until checkForFiles = ""
theFiles(counter, 1) = checkForFiles
Set fsoFile = fs
penTextFile(Trim(Work_Folder) & Trim(checkForFiles), ForReading)
theFiles(counter, 2) = fsoFile.ReadAll
fsoFile.Close
counter = counter + 1
'now try for another file
checkForFiles = Dir
Loop
Dim maxFile As Integer
maxFile = counter - 1
Dim outputFile As TextStream
Set outputFile = fso.CreateTextFile(Trim(Output_Folder) & Trim
(theFilename) & ".html", True)
If maxFile = 1 Then
'do the replaces to cleanup the output HTML formatting
'since Access doesn't save it to look real nice
'(note that this function returns the cleaned up HTML, so we set the
return
' of the function to the variable of the original HTML being sent in)
theFiles(1, 2) = CleanupHTMLFormatting(theFiles(1, 2))
'if there is only 1 file then we just write it out
outputFile.Write theFiles(1, 2)
Else
'if there are multiple files then we must parse and rejoin
'1st write out the first file without the closing tags
theFiles(1, 2) = CleanupHTMLFormatting(theFiles(1, 2))
outputFile.Write Left(theFiles(1, 2), (InStrRev(theFiles(1, 2),
"</TABLE>") + 9))
Dim startPos As Double, endPos As Double
'now do any remaining files, with just the actual body stuff
For counter = 2 To maxFile
startPos = InStr(theFiles(counter, 2), "<TABLE ") - 1
endPos = InStrRev(theFiles(counter, 2), "</TABLE>") + 8
theFiles(counter, 2) = CleanupHTMLFormatting(theFiles(counter, 2))
outputFile.Write Mid(theFiles(counter, 2), startPos, endPos -
startPos)
Next counter
'and finally add the closing tags
outputFile.Write "</BODY></HTML>"
End If
outputFile.Close
Set fso = Nothing
End Function
*** END CODE SAMPLE ***
Now here is the 2nd function. It is called from the first one
*** BEGIN CODE SAMPLE ***
Function CleanupHTMLFormatting(origHTML As String) As String
'first, change any ~HTML: insert HR here~ text to an actual HR tag
CleanupHTMLFormatting = Replace(origHTML, "~HTML: insert HR here~", "<HR
size=4 color=black width=100%>")
'now, change any ~HTML: insert blank line here~ text to a <BR> tag
CleanupHTMLFormatting = Replace(CleanupHTMLFormatting, "~HTML: insert
blank line here~", "<BR>")
'get rid of any <a href... tags since they are the Next Page, Prev Page,
etc links that we don't need
Dim myRegExp As RegExp
Set myRegExp = New RegExp
myRegExp.Pattern = "<a href.*</a>"
myRegExp.Global = True
myRegExp.IgnoreCase = True
myRegExp.Multiline = True
CleanupHTMLFormatting = myRegExp.Replace(CleanupHTMLFormatting, "")
Set myRegExp = Nothing
CleanupHTMLFormatting = Fix_Subtotal_Alignment(CleanupHTMLFormatting)
End Function
*** END CODE SAMPLE ***
*** BEGIN CODE SAMPLE ***
Function Fix_Subtotal_Alignment(theText)
Dim CRLF
CRLF = Chr(13) & Chr(10)
Dim startPos, endPos, startBlock, endBlock
Dim foreText, oldText, newText, postText
Dim objRegExpr, colMatches, objMatch
startPos = 1
Do While InStr(startPos, theText, "~HTML:start total row~") > 0
startPos = InStr(startPos, theText, "~HTML:start total row~")
endPos = InStr(startPos, theText, "~HTML:end total row~")
startBlock = InStrRev(theText, "<TABLE", startPos) - 1
endBlock = InStr(endPos, theText, "</TABLE>") + 8
foreText = Left(theText, startBlock - 1)
postText = Right(theText, (Len(theText) - endBlock))
oldText = Mid(theText, startBlock, (endBlock - startBlock))
Set objRegExpr = New RegExp
objRegExpr.Pattern = "COLOR=#000000>.*</FONT>"
objRegExpr.Global = True
objRegExpr.IgnoreCase = True
Set colMatches = objRegExpr.Execute(oldText)
newText = "<TABLE BORDER=0 CELLSPACING=0 CELLPADDING=0 >" & CRLF &
"<TR HEIGHT=14>" & CRLF
newText = newText & "<TD WIDTH=64 ALIGN=LEFT > <BR></TD><TD
WIDTH=500 ALIGN=RIGHT ><FONT style=FONT-SIZE:8pt FACE=""Arial""
COLOR=#000000>"
newText = newText & Mid(colMatches(0).Value, 15, Len(colMatches(0).
Value) - 21) & "</FONT></TD>" & CRLF
newText = newText & "<TD WIDTH=40 ALIGN=RIGHT ><FONT style=FONT-SIZE:
8pt FACE=""Arial"" COLOR=#000000>"
newText = newText & Mid(colMatches(1).Value, 15, Len(colMatches(0).
Value) - 21) & "</FONT></TD>" & CRLF
newText = newText & "<TD WIDTH=96 ALIGN=RIGHT ><FONT style=FONT-SIZE:
8pt FACE=""Arial"" COLOR=#000000>"
newText = newText & Mid(colMatches(2).Value, 15, Len(colMatches(0).
Value) - 21) & "</FONT></TD>" & CRLF
newText = newText & "</TR>" & CRLF & "</TABLE>" & CRLF
theText = foreText & newText & postText
startPos = startPos + 20
Set colMatches = Nothing
Set objRegExpr = Nothing
Loop
Fix_Subtotal_Alignment = theText
End Function
*** END CODE SAMPLE ***
