home *** CD-ROM | disk | FTP | other *** search
/ Planet Source Code Jumbo …e CD Visual Basic 1 to 7 / 1_2002.ISO / Data / Zips / Demonstrat196875172001.psc / Recordset2HTML.bas < prev   
Encoding:
BASIC Source File  |  2001-05-16  |  12.1 KB  |  263 lines
  1. Attribute VB_Name = "Recordset2HTML"
  2. '-----------------------------------------------------------------------------------
  3. ' Author: Edwin Vermeer, vermeer@beursmonitor.com, www.beursmonitor.com
  4. '-----------------------------------------------------------------------------------
  5. ' Functions and procedures in this module:
  6. ' Sub CreateHTML : This procedure uses a recordset and a template file to create one or more HTML pages
  7. ' Function CreateHTMLpage : This function will return a HTML text base on a recordset and a template
  8. ' Funttion ReplaceFieldTags : This function replace all tags with the values of the current record in a recordset
  9. ' Sub test : This procedure is testing the above functions
  10. '-----------------------------------------------------------------------------------
  11. Option Explicit
  12. Dim myCounter As Long
  13.  
  14.  
  15.  
  16.  
  17. Public Sub CreateHTML(rs As Recordset, Template As String, TargetDir As String, FileGrouping As String)
  18. '-----------------------------------------------------------------------------------
  19. ' Author: Edwin Vermeer, vermeer@beursmonitor.com, www.beursmonitor.com
  20. '-----------------------------------------------------------------------------------
  21. ' This subroutine creates one or more HTML files base on a recordset and a
  22. ' template file. All files are stored in the targetdir. For each different
  23. ' value in the field Filegrouping in the recordset a file will be created.
  24. '-----------------------------------------------------------------------------------
  25. ' rs :           Can be any reccordset. The sorting order must be set to the filegrouping and page groupings
  26. ' Template :     The filename (including path) of the template file
  27. ' TargetDir :    The location where the HTML file(s) will be created
  28. ' FileGrouping : A file will be created for each value int the field with this name.
  29. '-----------------------------------------------------------------------------------
  30. ' The next line is showing a (shortest possible) template with all functionality
  31. ' a<%b%><%GROUP c%>d<%e%><%GROUP DetailSection%>f<%g%><%ENDGROUP%>h<%i%><%ENDGROUP%>j<%k%>
  32. ' The result of this template can be described as:
  33. ' the page header: a (value of field b)
  34. '   and now for each value in c: d (value of field e)
  35. '     then for each reccord: f (value of field g)
  36. '   the footer for each value in c: h (value of field i)
  37. ' then the page footer: j (value of field) k
  38. '-----------------------------------------------------------------------------------
  39. Dim FileLine As String
  40. Dim TemplateFile As String
  41. Dim newfile As String
  42. Dim FileGroupingValue As String
  43. Dim i As Long
  44. Dim j As Long
  45.   
  46.   If rs.EOF Then Exit Sub
  47.   
  48.   ' Read the template into the memmory
  49.   Open Template For Input As #1
  50.   While Not EOF(1)
  51.     Line Input #1, FileLine
  52.     TemplateFile = TemplateFile & FileLine & vbCrLf
  53.   Wend
  54.   Close #1
  55.  
  56.   ' In case we want to display a progress bar/counter
  57.   rs.MoveLast
  58.   myCounter = rs.RecordCount
  59.   rs.MoveFirst
  60.  
  61.   ' OK, now we want to process all reccords
  62.   While Not rs.EOF
  63.     FileGroupingValue = rs(FileGrouping)
  64.     newfile = CreateHTMLpage(rs, TemplateFile, FileGrouping)
  65.     
  66.     ' Write the HTML file
  67.     Open TargetDir & FileGroupingValue & ".html" For Output As #1
  68.     Print #1, newfile
  69.     Close #1
  70.     If Not rs.EOF Then FileGroupingValue = rs(FileGrouping)
  71.   Wend
  72.   myCounter = 0
  73.  
  74. End Sub
  75.  
  76.  
  77.  
  78.  
  79. Public Function CreateHTMLpage(rs As Recordset, TemplateFile As String, FileGrouping As String) As String
  80. '-----------------------------------------------------------------------------------
  81. ' Author: Edwin Vermeer, vermeer@beursmonitor.com, www.beursmonitor.com
  82. '-----------------------------------------------------------------------------------
  83. ' This function is called from the CreateHTML routine but can also be runned seperatly
  84. ' Based on the recordset rs and the TemplateFile it will return a string.
  85. ' This function whill start at the current reccord and stop as soon as the field
  86. ' with the nime FileGrouping is changed.
  87. '-----------------------------------------------------------------------------------
  88. ' rs :           Can be any reccordset. The sorting order must be set to the filegrouping and page groupings
  89. ' TemplateTile : The complete template as a string.
  90. ' FileGrouping : A file will be created for each value int the field with this name.
  91. '-----------------------------------------------------------------------------------
  92. Dim GroupingBy() As String
  93. Dim GroupingValue() As String
  94. Dim GroupingHeader() As String
  95. Dim GroupingFooter() As String
  96. Dim FileGroupingValue As String
  97. Dim WorkingOnFile As Boolean
  98. Dim CurrentGroupingLevel As Long
  99. Dim SaveCurrentGroupingLevel As Long
  100. Dim i As Long
  101. Dim newfile As String
  102.  
  103.   ' First we need to preprocess the template into easy to handle arrays.
  104.   '---------------------------------------------------------------------
  105.   ' put all the group headers into an array. The last cell will contain the detail section plus all footers.
  106.   GroupingHeader = Split(TemplateFile, "<%GROUP ")
  107.   ' use the last header cell and put all the footers into an array. the last cell will contain the detail section
  108.   GroupingFooter = Split(GroupingHeader(UBound(GroupingHeader)), "<%ENDGROUP%>")
  109.   ' The group names are still in header array. Extract them to a sepperate array
  110.   ReDim GroupingBy(UBound(GroupingHeader))
  111.   For i = 0 To UBound(GroupingHeader) - 2
  112.     ' First put the grouping by name into a sepperate array
  113.     GroupingBy(i + 1) = Left(GroupingHeader(i + 1), InStr(1, GroupingHeader(i + 1), "%>") - 1)
  114.     ' Then remove this grouping by name from the header array
  115.     GroupingHeader(i + 1) = Mid(GroupingHeader(i + 1), InStr(1, GroupingHeader(i + 1), "%>") + 2)
  116.   Next i
  117.   ' If we do have grouping then the grouping by name of the last group will be in the footer instead of the header.
  118.   If UBound(GroupingHeader) > 0 Then
  119. '     GroupingBy(UBound(GroupingHeader) - 1) = Left(GroupingFooter(0), InStr(1, GroupingFooter(0), "%>") - 1)
  120.     GroupingFooter(0) = Mid(GroupingFooter(0), InStr(1, GroupingFooter(0), "%>") + 2)
  121.   End If
  122.   ' Just clear the cell that we don't need (not realy neccessery)
  123.   GroupingHeader(UBound(GroupingHeader)) = ""
  124.     
  125.   ' Remember the current grouping by values
  126.   ReDim GroupingValue(UBound(GroupingHeader))
  127.   For i = 1 To UBound(GroupingBy) - 1
  128.     GroupingValue(i) = rs(GroupingBy(i))
  129.   Next
  130.   FileGroupingValue = rs(FileGrouping)
  131.    
  132.   ' Now create the HTML file
  133.   WorkingOnFile = True
  134.   newfile = ReplaceFieldTags(GroupingHeader(0), rs)
  135.   CurrentGroupingLevel = 1
  136.   While WorkingOnFile And Not rs.EOF
  137.     ' Put in the grouping headders if needed
  138.     While CurrentGroupingLevel < UBound(GroupingBy)
  139.       newfile = newfile & ReplaceFieldTags(GroupingHeader(CurrentGroupingLevel), rs)
  140.       CurrentGroupingLevel = CurrentGroupingLevel + 1
  141.     Wend
  142.       
  143.     ' add the detail section to the file
  144.     newfile = newfile & ReplaceFieldTags(GroupingFooter(0), rs)
  145.       
  146.     ' test if we need footers
  147.     rs.MoveNext
  148.     If rs.EOF Then
  149.       CurrentGroupingLevel = 1
  150.     Else
  151.       While rs(GroupingBy(CurrentGroupingLevel - 1)) <> GroupingValue(CurrentGroupingLevel - 1)
  152.         GroupingValue(CurrentGroupingLevel - 1) = rs(GroupingBy(CurrentGroupingLevel - 1))
  153.         CurrentGroupingLevel = CurrentGroupingLevel - 1
  154.         If CurrentGroupingLevel = 1 Then GoTo JumpOut
  155.       Wend
  156. JumpOut:
  157.     End If
  158.     rs.MovePrevious
  159.       
  160.     ' Put in the grouping footers if needed
  161.     SaveCurrentGroupingLevel = CurrentGroupingLevel
  162.     While CurrentGroupingLevel < UBound(GroupingBy)
  163.       newfile = newfile & ReplaceFieldTags(GroupingFooter(CurrentGroupingLevel), rs)
  164.       CurrentGroupingLevel = CurrentGroupingLevel + 1
  165.     Wend
  166.     CurrentGroupingLevel = SaveCurrentGroupingLevel
  167.       
  168.     rs.MoveNext
  169.     myCounter = myCounter - 1
  170.     DoEvents
  171.     If Not rs.EOF Then If FileGroupingValue <> rs(FileGrouping) Then WorkingOnFile = False
  172.   Wend
  173.   rs.MovePrevious
  174.   newfile = newfile & ReplaceFieldTags(GroupingFooter(UBound(GroupingFooter)), rs)
  175.   rs.MoveNext
  176.  
  177.   CreateHTMLpage = newfile
  178.  
  179. End Function
  180.  
  181.  
  182.  
  183.  
  184. Public Function ReplaceFieldTags(strText As String, rs As Recordset) As String
  185. '-----------------------------------------------------------------------------------
  186. ' Author: Edwin Vermeer, vermeer@beursmonitor.com, www.beursmonitor.com
  187. '-----------------------------------------------------------------------------------
  188. ' This function will replace all tags in strText that are formated like
  189. ' <%fieldname%> with the value of that fieldname. This will be done for the
  190. ' current reccord in the recordset rs
  191. '-----------------------------------------------------------------------------------
  192. ' rs :      The recordset where the current reccord will be used
  193. ' strText : The text field where all the tags will be replaced
  194. '-----------------------------------------------------------------------------------
  195. Dim i As Long
  196. Dim j As Long
  197.  
  198.   ReplaceFieldTags = strText
  199.   For i = 0 To rs.Fields.Count - 1
  200.     j = InStr(1, ReplaceFieldTags, "<%" & rs(i).Name & "%>")
  201.     While j > 0
  202.       ReplaceFieldTags = Left(ReplaceFieldTags, j - 1) & rs(i) & Mid(ReplaceFieldTags, j + 4 + Len(rs(i).Name))
  203.       j = InStr(1, ReplaceFieldTags, "<%" & rs(i).Name & "%>")
  204.     Wend
  205.   Next i
  206.  
  207.   ' Now we will replace some constant tags
  208.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "HomePage", "www.beursmonitor.com")
  209.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "eMail", "vermeer@beursmonitor.com")
  210.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.Title", App.Title)
  211.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.Version", App.Major & "." & App.Minor)
  212.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.Comments", App.Comments)
  213.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.CompanyName", App.CompanyName)
  214.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.FileDescription", App.FileDescription)
  215.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.LegalCopyright", App.LegalCopyright)
  216.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.LegalTrademarks", App.LegalTrademarks)
  217.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "App.ProductName", App.ProductName)
  218.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "Date", Date)
  219.   ReplaceFieldTags = ReplaceTags(ReplaceFieldTags, "Time", Time)
  220.  
  221. End Function
  222.  
  223.  
  224. Public Function ReplaceTags(strText As String, strTag As String, strReplaceWith) As String
  225. '-----------------------------------------------------------------------------------
  226. ' Author: Edwin Vermeer, vermeer@beursmonitor.com, www.beursmonitor.com
  227. '-----------------------------------------------------------------------------------
  228. ' This function will replace all tags in strText with the name strTag that are
  229. ' formated like <%tagname%> with the value of strReplaceWith.
  230. '-----------------------------------------------------------------------------------
  231. ' strTag :         The name of the tag.
  232. ' strText :        The text field where all the tags will be replaced.
  233. ' strReplaceWith : The text that will be put inplace of the tag
  234. '-----------------------------------------------------------------------------------
  235. Dim j As Long
  236.  
  237.   ReplaceTags = strText
  238.   j = InStr(1, ReplaceTags, "<%" & strTag & "%>")
  239.   While j > 0
  240.     ReplaceTags = Left(ReplaceTags, j - 1) & strReplaceWith & Mid(ReplaceTags, j + 4 + Len(strTag))
  241.     j = InStr(1, ReplaceTags, "<%" & strTag & "%>")
  242.   Wend
  243.  
  244. End Function
  245.  
  246. Public Sub test()
  247. '-----------------------------------------------------------------------------------
  248. ' Author: Edwin Vermeer, vermeer@beursmonitor.com, www.beursmonitor.com
  249. '-----------------------------------------------------------------------------------
  250. ' This routine whill test the functioning of the CreateHTML procedure
  251. '-----------------------------------------------------------------------------------
  252. Dim ws As Workspace
  253. Dim db As Database
  254. Dim rs As Recordset
  255.  
  256.     Set ws = CreateWorkspace("", "admin", "")
  257.     Set db = ws.OpenDatabase(App.Path & "\BeursMonitor.mdb")
  258.     Set rs = db.OpenRecordset("Select * from HuidigeKoers Where (((HuidigeKoers.Tijd) > DateAdd('d', -7, Now()))) Order by Bron, Groep, Fonds")
  259.     CreateHTML rs, "c:\temp\template.htt", "c:\temp\", "Bron"
  260.  
  261. End Sub
  262.  
  263.