*** 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 = fso.OpenTextFile(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 ***
