Option Compare Database
Option Explicit
Public Title As String, Source As String, StyleSheet As String
Public filename As String, FileSuffix As String, BackgroundPicture As String
Public LinesOnPage As Long, PageCounter As Boolean
Public BorderWidth As Integer
Private intlocFile As Integer, lnglocCurPage As Long, lngTotalLines As Long
Private strlocFile As String, strlocPath As String
Private lngNavBar As Long, lngNavBarStyle As Long
Const navnone = 0, navtop = 1, navbottom = 2, navboth = 3
Const navButton = -1, navText = -2
Public BodyTop As New StringObj, BodyFoot As New StringObj
Private Sub Class_Initialize()
LinesOnPage = 0
lngTotalLines = 0
lnglocCurPage = 1
lngNavBar = navbottom
lngNavBarStyle = navText
FileSuffix = ".html"
BodyFoot.Init "", vbCrLf & "
"
BodyTop.Init "", vbCrLf & "
"
End Sub
Property Let NavBar(cHow As String)
Select Case cHow
Case "none"
lngNavBar = navnone
Case "top"
lngNavBar = navtop
Case "bottom"
lngNavBar = navbottom
Case "both"
lngNavBar = navboth
End Select
End Property
Property Let NavBarStyle(cHow As String)
Select Case cHow
Case "buttons"
lngNavBarStyle = navButton
Case "text"
lngNavBarStyle = navText
End Select
End Property
Property Let BodyTextAbove(ByVal cSome As String)
BodyTop.Add cSome
End Property
Property Let BodyTextBelow(ByVal cSome As String)
BodyFoot.Add cSome
End Property
Sub MakeFile()
SplitFileName
OpeintlocFile True
WriteHTMLHead
WriteHTMLBody
CloseFile
End Sub
Private Sub WriteHTMLHead()
Print #intlocFile, ""
Print #intlocFile, "
"
Print #intlocFile, "" & Title & ""
If StyleSheet <> "" Then
Print #intlocFile, ""
End If
Print #intlocFile, ""
End Sub
Private Sub WriteHTMLBody()
Dim rs As Recordset, curLine As Long
WriteHTMLBodyStart
Set rs = CurrentDb.OpenRecordset(Source, dbOpenDynaset)
If LinesOnPage = 0 Then 'all on one page
LinesOnPage = AllLines
End If
Do Until rs.EOF
WriteHTMLTableLine rs
rs.MoveNext
curLine = curLine + 1
If curLine > LinesOnPage Then
StartNewFile
curLine = 1
End If
Loop
WriteHTMLTableTail
WriteHTMLBodyEnd
rs.Close
Set rs = Nothing
End Sub
Private Sub OpeintlocFile(Optional bWithPath = False)
intlocFile = FreeFile
Open NumberedFileName(lnglocCurPage, bWithPath) For Output As intlocFile
End Sub
Private Sub CloseFile()
Close intlocFile
intlocFile = 0
End Sub
Private Sub WriteHTMLTableHead()
Dim rs As Recordset, fld As Field
Print #intlocFile, "
"
Set rs = CurrentDb.OpenRecordset(Source)
For Each fld In rs.Fields
Print #intlocFile, "
" & fld.Name & "
"
Next
End Sub
Private Sub WriteHTMLTableTail()
Print #intlocFile, "
"
End Sub
Private Sub WriteHTMLTableLine(rs As Recordset)
Dim fld As Field
Print #intlocFile, "
"
For Each fld In rs.Fields
Print #intlocFile, "
" & fld.Value & "
"
Next
Print #intlocFile, "
"
End Sub
Private Sub StartNewFile()
WriteHTMLTableTail
WriteHTMLBodyEnd
CloseFile
lnglocCurPage = lnglocCurPage + 1
OpeintlocFile True
WriteHTMLHead
WriteHTMLBodyStart
End Sub
Private Sub WriteNavBar()
Print #intlocFile, ""
Print #intlocFile, "
"
End Sub
Private Function NavBarElement(Whereto As String) As String
Select Case lngNavBarStyle
Case navButton
NavBarElement = ""
Case navText
NavBarElement = Whereto & " "
End Select
End Function
Private Sub WriteHTMLBodyStart()
If BackgroundPicture <> "" Then
Print #intlocFile, ""
Else
Print #intlocFile, ""
End If
Print #intlocFile, BodyTop.Value
If lngNavBar And navtop Then
WriteNavBar
End If
WriteHTMLTableHead
End Sub
Private Sub WriteHTMLBodyEnd()
If lngNavBar And navbottom Then
WriteNavBar
End If
Print #intlocFile, ""
End Sub
Private Function AllLines() As Long
Dim rs As Recordset
If lngTotalLines = 0 Then
Set rs = CurrentDb.OpenRecordset(Source)
rs.MoveLast
lngTotalLines = rs.RecordCount
rs.Close
Set rs = Nothing
End If
AllLines = lngTotalLines
End Function
Private Function NumberedFileName(ByVal nPage As Long, Optional WithPath = False) As String
If nPage > 1 Then
NumberedFileName = IIf(WithPath, filename, strlocFile) & "_" & Format(nPage) & FileSuffix
Else
NumberedFileName = IIf(WithPath, filename, strlocFile) & FileSuffix
End If
End Function
Private Sub SplitFileName()
Dim interm As New StringObj, gotpath As New StringObj
If InStr(filename, "\") = 0 Then
interm.Init filename, "/"
gotpath.Init "", "/"
Else
interm.Init filename, "\"
gotpath.Init "", "\"
End If
Do While interm.ItemCount > 1
gotpath.Add interm.Remove
Loop
strlocFile = interm.Value
strlocPath = gotpath.Value
End Sub