1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343
| 'Author: Allen Browne
Option Compare Database
Option Explicit
'Author and Copyright data will be used in the HTML header.
Private Const mstrcAuthor = "" 'Insert your name inside the quotes.
Private Const mstrcCopyright = "" 'Whoever is responsible for the web page, in the quotes.
Private Const mstrcCSS = "AccessOutput.css" 'Include the path if the CSS is not in the same folder.
Private Const mstrcDateFormat = "General Date" 'How to format Date/Time fields.
Private Const mstrcCurrencyFormat = "Currency" 'How to format Currency fields.
Private Const mstrcYesNoFormat = "Yes/No" 'How to format Yes/No fields.
Function Test1()
'This creates a file named "MyTable.htm" in the current directory, from the records in MyTable.
Call OutputHTML("MyTable")
End Function
Function Test2()
'This outputs the same records to the named file, and adds the text to the table.
Dim strMsg As String
strMsg = OutputHTML("MyTable", "C:\MyFolder\MyFile.htm", "Show this in browser title bar", "Show this at top of page", _
"This sample was generated from Access using a utility by", "That's all")
MsgBox strMsg, vbInformation, "Results"
End Function
Function Test3()
'This does the same, but illustrates how you can add your own HTML for the head and foot paragraphs.
Debug.Print OutputHTML("MyTable", "C:\MyFolder\MyFile.htm", "My brower's title", "Records from MyTable", _
"<p>G'day.</p><p>Here's <b>the data</b>.</p>", "<p align=""center"">--Dated " & Now() & "--</p>")
End Function
'*****************************
'This is the main function
'*****************************
Public Function OutputHTML(strTableOrQuery As String, _
Optional ByVal strOutputFile As String, _
Optional strTitle As String, _
Optional strHeadingText As String, _
Optional strHeadParagraph As String, _
Optional strFootParagraph As String, _
Optional strDescription As String, _
Optional strKeywords As String, _
Optional bShowItNow As Boolean = True) As String
On Error GoTo Err_Handler
Dim db As DAO.Database 'This database
Dim rs As DAO.Recordset 'Table/query
Dim fld As DAO.Field 'Each field.
Dim iFileNum As Integer 'File number for output file.
Dim lngKt As Long 'Number of records
'Open the source table/query, and start the output file.
Set db = CurrentDb()
Set rs = db.OpenRecordset(strTableOrQuery)
strOutputFile = FixupFilename(strOutputFile, strTableOrQuery, "htm")
iFileNum = FreeFile
Open strOutputFile For Output As #iFileNum
DoCmd.Hourglass True
'Create the HTML Header
Print #1, "<!DOCTYPE HTML PUBLIC ""-//W3C//DTD HTML 4.01 Transitional//EN"" ""http://www.w3.org/TR/html4/loose.dtd"">"
Print #1, "<html>"
Print #1, "<head>"
Print #1, "<meta http-equiv=""Content-Type"" content=""text/html; charset=windows-1252"">"
Print #1, "<meta http-equiv=""Content-Language"" content=""en-us"">"
If strTitle <> vbNullString Then
Print #1, "<title>" & strTitle & "</title>"
End If
If strDescription <> vbNullString Then
Print #1, "<meta name=""description"" content=""" & strDescription & """>"
End If
If strKeywords <> vbNullString Then
Print #1, "<META name=""keywords"" content=""" & strKeywords & """>"
End If
Print #1, "<META name=""Author"" content=""" & mstrcAuthor & """>"
Print #1, "<META name=""copyright"" content=""© " & Year(Date) & " " & mstrcCopyright & """>"
Print #1, "<base target=""_top"">"
If mstrcCSS <> vbNullString Then
Print #1, "<LINK rel=""stylesheet"" type=""text/css"" href=""" & mstrcCSS & """>"
End If
Print #1, "</head>"
'Start the body with the heading and header paragraph
Print #1, "<body>"
If strHeadingText <> vbNullString Then
If strHeadingText Like "<*" Then
Print #1, strHeadingText
Else
Print #1, "<h1>" & strHeadingText & "</h1>"
End If
End If
If strHeadParagraph <> vbNullString Then
If strHeadParagraph Like "<*" Then
Print #1, strHeadParagraph
Else
Print #1, "<p>" & strHeadParagraph & "</p>"
End If
End If
'Start a table, with a column for each field.
Print #1, "<table width=""100%"">"
Print #1, "<tr>"
For Each fld In rs.Fields
If Not IgnoreField(fld) Then
'If the field has a Caption, use that; otherwise its name.
If HasProperty(fld, "Caption") Then
Print #1, "<th>" & fld.Properties("Caption") & "</th>"
Else
Print #1, "<th>" & ConvertMixedCase(fld.Name) & "</th>"
End If
End If
Next
Print #1, "</tr>"
'Loop through the records, adding rows to the HTML table.
Do While Not rs.EOF
Print #1, "<tr>"
For Each fld In rs.Fields
If Not IgnoreField(fld) Then
Print #1, FormatCell(fld)
End If
Next
Print #1, "</tr>"
lngKt = lngKt + 1
rs.MoveNext
Loop
'Close the table, add the footer paragraph, and complete the HTML.
Print #1, "</table>"
If strFootParagraph <> vbNullString Then
If strFootParagraph Like "<*" Then
Print #1, strFootParagraph
Else
Print #1, "<p>" & strFootParagraph & "</p>"
End If
End If
Print #1, "</body>"
Print #1, "</html>"
'Return information about the HTML file.
OutputHTML = strOutputFile & " written " & Now() & " has " & _
IIf(lngKt = 1, "1 record", lngKt & " records") & " from " & strTableOrQuery & "."
Exit_Handler:
'Clean up. (These operations must happen even after an error.)
On Error Resume Next
Close #iFileNum
Set fld = Nothing
rs.Close
Set rs = Nothing
Set db = Nothing
If bShowItNow Then
FollowHyperlink strOutputFile
End If
DoCmd.Hourglass False
Exit Function
Err_Handler:
MsgBox "Error " & Err.Number & ": " & Err.Description, vbExclamation, "OutputHTML()"
Resume Exit_Handler
End Function
Private Function ConvertMixedCase(ByVal strIn As String) As String
Dim lngStart As Long 'Loop through string.
Dim strOut As String 'Output string.
Dim bWasSpace As Boolean 'Last char. was a space.
Dim bWasUpper As Boolean 'Last char. was upper case.
strIn = Trim$(strIn) 'Remove leading/trailing spaces.
bWasUpper = True 'Initialize for no first space.
For lngStart = 1& To Len(strIn)
Select Case Asc(Mid(strIn, lngStart, 1&))
Case vbKeyA To vbKeyZ 'Upper case: insert a space.
If bWasSpace Or bWasUpper Then
strOut = strOut & Mid(strIn, lngStart, 1&)
Else
strOut = strOut & " " & Mid(strIn, lngStart, 1&)
End If
bWasSpace = False
bWasUpper = True
Case 95 'Underscore: replace with space.
If Not bWasSpace Then
strOut = strOut & " "
End If
bWasSpace = True
bWasUpper = False
Case vbKeySpace 'Space: output and set flag.
If Not bWasSpace Then
strOut = strOut & " "
End If
bWasSpace = True
bWasUpper = False
Case Else 'Any other char: output.
strOut = strOut & Mid(strIn, lngStart, 1&)
bWasSpace = False
bWasUpper = False
End Select
Next
ConvertMixedCase = strOut
End Function
Private Function IgnoreField(fld As DAO.Field) As Boolean
'Return True for OLE fields, binary fields.
Select Case fld.Type
Case dbLongBinary, dbBinary, dbVarBinary
IgnoreField = True
End Select
End Function
Private Function IsRichText(fld As DAO.Field) As Boolean
On Error Resume Next
'Purpose: Returns True if the field has its TextFormat property set to 1.
' False for all other cases (no such property, set to 0, or error.)
Const btRich As Byte = 1
IsRichText = (fld.Properties("TextFormat") = btRich)
End Function
Private Function HasProperty(Obj As Object, strPropName As String) As Boolean
'Purpose: Return true if the object has the property.
Dim varDummy As Variant
On Error Resume Next
varDummy = Obj.Properties(strPropName)
HasProperty = (Err.Number = 0)
End Function
Private Function FixupFilename(ByVal strFileName As String, strDefaultName As String, strDefaultExt As String) As String
'Use the default name if the file name is blank
If strFileName = vbNullString Then
strFileName = strDefaultName
End If
'If the file name is a path, add the default file name after a slash.
If FolderExists(strFileName) Then
If Right$(strFileName, 2&) <> "\" Then
strFileName = strFileName & "\"
End If
strFileName = strFileName & strDefaultName
Else
strFileName = strFileName
End If
'If the file name lacks an extension, add the default extension.
If (InStr(InStrRev(strFileName, "\") + 1&, strFileName, ".") = 0&) And (strDefaultExt <> vbNullString) Then
If strDefaultExt Like ".*" Then
strFileName = strFileName & strDefaultExt
Else
strFileName = strFileName & "." & strDefaultExt
End If
End If
FixupFilename = strFileName
End Function
Private Function FolderExists(strPath As String) As Boolean
On Error Resume Next
FolderExists = ((GetAttr(strPath) And vbDirectory) = vbDirectory)
End Function
Private Function FormatCell(fld As DAO.Field) As String
'Purpose: Return the string for the cell of a table, based on the value of the field.
Dim rsMVF As DAO.Recordset 'To handle Multi-Valued fields.
Dim strOut As String 'Output string
Dim bAlignRight As Boolean 'Flag to right-align this table cell.
Dim bIsFormatted As Boolean 'Flag if already formatted as HTML.
Dim lngLen As Long 'Length of string.
Const strcSep = ", " 'Separator between items in multi-valued fields.
If Not IsNull(fld.Value) Then
'If this is a Multi-Valued Field, loop the records within it.
If VarType(fld.Value) = vbObject Then
Set rsMVF = fld.Value
Do While Not rsMVF.EOF
If fld.Type = 101 Then 'dbAttachment
strOut = strOut & rsMVF!filename & strcSep
Else
strOut = strOut & rsMVF![Value].Value & strcSep
End If
rsMVF.MoveNext
Loop
'Remove trailing separator.
lngLen = Len(strOut) - Len(strcSep)
If lngLen > 0& Then
strOut = Left(strOut, lngLen)
End If
Set rsMVF = Nothing
Else
Select Case fld.Type
Case dbText, dbGUID, dbChar 'Text fields: use the value.
strOut = fld.Value
Case dbMemo 'Memo: handle hyperlinks and rich text.
If (fld.Attributes And dbHyperlinkField) <> 0& Then
strOut = "<a href=""" & Replace(HyperlinkPart(fld.Value, acAddress), " ", "%20") & """>" & _
HyperlinkPart(fld.Value, acDisplayedValue) & "</a>"
bIsFormatted = True
Else
strOut = fld.Value
bIsFormatted = IsRichText(fld)
End If
Case dbLong, dbInteger, dbDouble, dbSingle, dbByte, dbDecimal, dbFloat, dbBigInt, dbNumeric 'Numbers
strOut = fld.Value
bAlignRight = True
Case dbCurrency 'Currency fields.
strOut = Format$(fld.Value, mstrcCurrencyFormat)
bAlignRight = True
Case dbDate, dbTime, dbTimeStamp 'Date/time fields
strOut = Format$(fld.Value, mstrcDateFormat)
bAlignRight = True
Case dbBoolean 'Yes/No fields.
strOut = Format$(fld.Value, mstrcYesNoFormat)
Case Else 'Other types.
strOut = fld.Value
End Select
End If
End If
If strOut = vbNullString Then
'Use a non-breaking space for Null or zero-length string (to keep HTML table right.)
strOut = " "
ElseIf Not bIsFormatted Then
'Unless formatting is embedded, handle special characters.
strOut = Replace(strOut, "&", "&")
strOut = Replace(strOut, """", """)
strOut = Replace(strOut, "<", "<")
strOut = Replace(strOut, ">", ">")
strOut = Replace(strOut, vbCrLf, "<br>")
strOut = Replace(strOut, " ", " ")
End If
'Add the cell tag, aligned right for numbers/dates.
If bAlignRight Then
strOut = "<td align=""right"">" & strOut & "</td>"
Else
strOut = "<td>" & strOut & "</td>"
End If
FormatCell = strOut
End Function |
Partager