Component File /DocBuilderClass.vb (VB.NET)
1: Option Strict Off
2: Option Explicit On
3: Friend Class DocBuilderClass
4: Public DatabaseStoreConnectionString As String
5: Public DataStore As New DataStoreClass
6: Public DocParseID As Integer
7: Public DocFolderPath As String
8: Public FilesCreated As New Collection
9: Public HTMLHelpIndexContents As New Collection
10: Public MakeRTFFile As Boolean
11: Public MakeTextFile As Boolean
12: Public MakeHTMLHelp As Boolean
13: Public UseColourCoding As Boolean
14: Private Structure STARTUPINFO
15: Dim cb As Integer
16: Dim lpReserved As String
17: Dim lpDesktop As String
18: Dim lpTitle As String
19: Dim dwX As Integer
20: Dim dwY As Integer
21: Dim dwXSize As Integer
22: Dim dwYSize As Integer
23: Dim dwXCountChars As Integer
24: Dim dwYCountChars As Integer
25: Dim dwFillAttribute As Integer
26: Dim dwFlags As Integer
27: Dim wShowWindow As Short
28: Dim cbReserved2 As Short
29: Dim lpReserved2 As Integer
30: Dim hStdInput As Integer
31: Dim hStdOutput As Integer
32: Dim hStdError As Integer
33: End Structure
34:
35: Private Structure PROCESS_INFORMATION
36: Dim hProcess As Integer
37: Dim hThread As Integer
38: Dim dwProcessID As Integer
39: Dim dwThreadID As Integer
40: End Structure
41:
42: Private Declare Function WaitForSingleObject Lib "kernel32" (ByVal hHandle As Integer, ByVal dwMilliseconds As Integer) As Integer
43:
44: 'UPGRADE_WARNING: Structure PROCESS_INFORMATION may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
45: 'UPGRADE_WARNING: Structure STARTUPINFO may require marshalling attributes to be passed as an argument in this Declare statement. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1050"'
46: Private Declare Function CreateProcessA Lib "kernel32" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByVal lpProcessAttributes As Integer, ByVal lpThreadAttributes As Integer, ByVal bInheritHandles As Integer, ByVal dwCreationFlags As Integer, ByVal lpEnvironment As Integer, ByVal lpCurrentDirectory As String, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Integer
47:
48: Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Integer) As Integer
49:
50: Private Declare Function GetExitCodeProcess Lib "kernel32" (ByVal hProcess As Integer, ByRef lpExitCode As Integer) As Integer
51:
52: Private Const NORMAL_PRIORITY_CLASS As Integer = &H20
53: Private Const INFINITE As Short = -1
54:
55: Public Function ExecCmd(ByRef cmdline As String) As Object
56: Dim ret As Integer
57: Dim proc As PROCESS_INFORMATION
58: Dim start As STARTUPINFO
59:
60: ' Initialize the STARTUPINFO structure:
61: start.cb = Len(start)
62:
63: ' Start the shelled application:
64: ret = CreateProcessA(vbNullString, cmdline, 0, 0, 1, NORMAL_PRIORITY_CLASS, 0, vbNullString, start, proc)
65:
66: ' Wait for the shelled application to finish:
67: ret = WaitForSingleObject(proc.hProcess, INFINITE)
68: Call GetExitCodeProcess(proc.hProcess, ret)
69: Call CloseHandle(proc.hThread)
70: Call CloseHandle(proc.hProcess)
71: 'UPGRADE_WARNING: Couldn't resolve default property of object ExecCmd. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
72: ExecCmd = ret
73: End Function
74:
75: Public Sub SetDataStoreConnectionString(ByRef ConnectionString As String)
76:
77: DatabaseStoreConnectionString = ConnectionString
78:
79: End Sub
80:
81:
82: Public Function BuildDocumentation(ByRef ParseID As Integer, ByRef FolderPath As String, ByRef BuildHTMLDocumentation As Boolean, ByRef BuildHTMLHelpDocumentation As Boolean, ByRef BuildTextDocumentation As Boolean, ByRef BuildRTFDocumentation As Boolean, ByRef ColourCodeSource As Boolean) As Boolean
83: Dim FileName As Object
84:
85: Dim PageBody As String
86: Dim PageTitle As String
87: Dim FileBody As String
88: Dim CommandText As String
89: Dim Result As Double
90: Dim RTFText As String
91: 'Dim DataStore As New DataStoreClass
92: DataStore.SetConnectionString((DatabaseStoreConnectionString))
93: 'Dim
94: DocParseID = ParseID
95: DocFolderPath = FolderPath
96:
97: MakeRTFFile = False
98: MakeHTMLHelp = False
99: MakeTextFile = False
100: UseColourCoding = False
101:
102: If BuildRTFDocumentation = True Then MakeRTFFile = True
103: If BuildTextDocumentation = True Then MakeTextFile = True
104: If BuildHTMLHelpDocumentation = True Then MakeHTMLHelp = True
105: If ColourCodeSource = True Then UseColourCoding = True
106:
107:
108: FormMain.DefInstance.UpdateStatus(("Building documentation for database " & CurrentDatabaseName))
109: Call FormMain.DefInstance.UpdateCurrentItem("")
110: Call AppendToLogFile(CurrentLogFileName, "Building documentation for project " & CurrentProjectName & vbCrLf)
111:
112: 'Build start of RTF file
113: If MakeRTFFile Then
114:
115: 'RTFText = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033\deflangfe1033{\fonttbl{\f0\fswiss\fprq2\fcharset0 Arial;}{\f1\froman\fprq2\fcharset0 Times New Roman;}}" & vbCrLf
116: 'RTFText = RTFText & "{\stylesheet{ Normal;}{\s1 heading 1;}{\s2 heading 2;}}" & vbCrLf
117:
118: RTFText = "{\rtf1\ansi\ansicpg1252\deff0\deflang1033\deflangfe1033{\fonttbl{\f0\froman\fprq2\fcharset0 Times New Roman;}{\f1\fswiss\fprq2\fcharset0 Arial;}}" & vbCrLf
119: RTFText = RTFText & "{\stylesheet{ Normal;}{\s1 heading 1;}{\s2 heading 2;}}" & vbCrLf
120: RTFText = RTFText & "\viewkind4\uc1\pard\keepn\s1\sb240\sa60\lang2057\kerning32\b\f0\fs32 SQL Server Documentation for project " & CurrentProjectName & "\par" & vbCrLf
121:
122: Call CreateFile(DocFolderPath, CurrentProjectName & ".rtf", RTFText)
123:
124: End If
125:
126: 'Build Default Page
127: PageTitle = "Database Documentation"
128: 'UPGRADE_WARNING: Couldn't resolve default property of object GetDefaultPageHTML(). Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
129: PageBody = GetDefaultPageHTML()
130: Call CreatePage("Documentation", DocFolderPath, "Default.htm", PageTitle, PageBody, False)
131:
132: 'Build Database List Page
133: PageTitle = "Databases"
134: 'UPGRADE_WARNING: Couldn't resolve default property of object GetDatabaseListPageHTML(). Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
135: PageBody = GetDatabaseListPageHTML()
136: Call CreatePage("Databases", DocFolderPath, "Databases.htm", PageTitle, PageBody, True)
137:
138: 'Build page for each database
139: FormMain.DefInstance.UpdateStatus(("Building databases documentation"))
140: Call AppendToLogFile(CurrentLogFileName, "Building databases documentation" & vbCrLf)
141: Call CreateDatabasePages()
142:
143: 'Build Tables list and table pages
144: FormMain.DefInstance.UpdateStatus(("Building tables documentation"))
145: Call AppendToLogFile(CurrentLogFileName, "Building tables documentation" & vbCrLf)
146: Call CreateTablesListAndTablesPages()
147:
148: 'Build View list and table pages
149: FormMain.DefInstance.UpdateStatus(("Building views documentation"))
150: Call AppendToLogFile(CurrentLogFileName, "Building views documentation" & vbCrLf)
151: Call CreateViewsListAndTablesPages()
152:
153: 'Build Stored Procedure list and table pages
154: FormMain.DefInstance.UpdateStatus(("Building stored procedure documentation"))
155: Call AppendToLogFile(CurrentLogFileName, "Building stored procedure documentation" & vbCrLf)
156: Call CreateStoredProceduresListAndTablesPages()
157:
158: 'Build Triggers list and table pages
159: FormMain.DefInstance.UpdateStatus(("Building triggers documentation"))
160: Call AppendToLogFile(CurrentLogFileName, "Building triggers documentation" & vbCrLf)
161: Call CreateTriggersListAndTablesPages()
162:
163: 'Build indexes list and table pages
164: FormMain.DefInstance.UpdateStatus(("Building indexes documentation"))
165: Call AppendToLogFile(CurrentLogFileName, "Building indexes documentation" & vbCrLf)
166: Call CreateIndexesListAndTablesPages()
167:
168: 'Build full text catalog list and table pages
169: FormMain.DefInstance.UpdateStatus(("Building full-text catalogs documentation"))
170: Call AppendToLogFile(CurrentLogFileName, "Building full-text catalogs documentation" & vbCrLf)
171: Call CreateFullTextCatalogsListAndTablesPages()
172:
173: 'Build DTS package documentation
174: If CurrentProjectDocumentDTSPackages Then
175: FormMain.DefInstance.UpdateStatus(("Building DTS package documentation"))
176: Call AppendToLogFile(CurrentLogFileName, "Building DTS package documentation" & vbCrLf)
177: Call CreateDTSPackagePages()
178: End If
179:
180: 'Build Jobs documentation
181: If CurrentProjectDocumentJobs Then
182: FormMain.DefInstance.UpdateStatus(("Building Jobs documentation"))
183: Call AppendToLogFile(CurrentLogFileName, "Building Jobs documentation" & vbCrLf)
184: Call CreateJobsPages()
185: End If
186:
187: Call FormMain.DefInstance.UpdateCurrentItem("")
188:
189: 'Build end of RTF file
190: If MakeRTFFile Then
191:
192: RTFText = "}" & vbCrLf
193: Call AppendFile(DocFolderPath, CurrentProjectName & ".rtf", RTFText)
194:
195: End If
196:
197: 'Optionally build the HTML Help documentation
198: Dim retval As Integer
199: If BuildHTMLHelpDocumentation Then
200:
201: FormMain.DefInstance.UpdateStatus(("Building project HTML Help documentation"))
202: Call AppendToLogFile(CurrentLogFileName, "Building project HTML Help documentation" & vbCrLf)
203:
204: 'Call CreateHTMLHelpProjectFile
205: FormMain.DefInstance.UpdateStatus(("Building content for HTML Help project file " & CurrentProjectName & ".hhp"))
206: Call AppendToLogFile(CurrentLogFileName, "Building content for HTML Help project file " & CurrentProjectName & ".hhp" & vbCrLf)
207: 'UPGRADE_WARNING: Couldn't resolve default property of object GetHTMLHelpProjectFile. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
208: FileBody = GetHTMLHelpProjectFile
209: Call CreateFile(DocFolderPath, CurrentProjectName & ".hhp", FileBody)
210:
211: FormMain.DefInstance.UpdateStatus(("Building content for HTML Help index file " & CurrentProjectName & ".hhk"))
212: Call AppendToLogFile(CurrentLogFileName, "Building content for HTML Help index file " & CurrentProjectName & ".hhk" & vbCrLf)
213: 'UPGRADE_WARNING: Couldn't resolve default property of object GetHTMLHelpIndexFile. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
214: FileBody = GetHTMLHelpIndexFile
215: Call CreateFile(DocFolderPath, CurrentProjectName & ".hhk", FileBody)
216:
217: FormMain.DefInstance.UpdateStatus(("Building content for HTML Help table of contents file " & CurrentProjectName & ".hhc"))
218: Call AppendToLogFile(CurrentLogFileName, "Building content for HTML Help table of contents file " & CurrentProjectName & ".hhc" & vbCrLf)
219: 'UPGRADE_WARNING: Couldn't resolve default property of object GetHTMLHelpTableOfContentsFile. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
220: FileBody = GetHTMLHelpTableOfContentsFile
221: Call CreateFile(DocFolderPath, CurrentProjectName & ".hhc", FileBody)
222:
223: 'Call HHC to build the documentation
224: FormMain.DefInstance.UpdateStatus(("Compiling project HTML Help documentation"))
225: CommandText = VB6.GetPath & "\hhc.exe """ & DocFolderPath & "\" & CurrentProjectName & ".hhp"""
226: Call AppendToLogFile(CurrentLogFileName, "Compiling project HTML Help documentation. Command used: " & CommandText & vbCrLf)
227:
228: 'Result = Shell(CommandText, vbNormalFocus)
229:
230: 'UPGRADE_WARNING: Couldn't resolve default property of object ExecCmd(). Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
231: retval = ExecCmd(CommandText)
232:
233: End If 'End of HTML Help documentation
234:
235:
236:
237: 'If HTML output not required then remove the HTML files
238: '??? Can't get this to work syncronously
239: BuildHTMLDocumentation = True
240: Dim FileSystemObject As New Scripting.FileSystemObject
241: If BuildHTMLDocumentation = False Then
242:
243: FormMain.DefInstance.UpdateStatus(("Removing temporary HTML files"))
244: Call AppendToLogFile(CurrentLogFileName, "Removing temporary HTML files" & vbCrLf)
245:
246:
247: For Each FileName In FilesCreated
248:
249: 'Debug.Print (FileName)
250:
251: 'Ensure output folder exists
252: 'UPGRADE_WARNING: Couldn't resolve default property of object FileName. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
253: If Not FileSystemObject.FileExists(DocFolderPath & "\" & FileName) Then
254:
255: 'UPGRADE_WARNING: Couldn't resolve default property of object FileName. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
256: FileSystemObject.DeleteFile(DocFolderPath & "\" & FileName, True)
257:
258: End If
259:
260: Next FileName
261:
262: End If
263:
264: Call AppendToLogFile(CurrentLogFileName, "**Documentation generation completed for project '" & CurrentProjectName & "'**" & vbCrLf)
265: BuildDocumentation = True
266:
267: End Function
268:
269:
270: Private Sub CreatePage(ByRef PageTitle As String, ByRef FolderName As String, ByRef FileName As String, ByRef HTMLTitle As String, ByRef HTMLBody As String, ByRef AddBodyTags As Boolean)
271: Dim TextFile As Object
272:
273: Call AppendToLogFile(CurrentLogFileName, "Creating file " & FolderName & "/" & FileName & " (" & HTMLTitle & ")" & vbCrLf)
274: FilesCreated.Add((FileName))
275: Dim HTML As String
276: Randomize()
277: Dim RandomNumber As Short
278: RandomNumber = Int((10 - 0 + 1) * Rnd() + 0)
279:
280: HTML = "<html>" & vbCrLf
281: HTML = HTML & "<head>" & vbCrLf
282: HTML = HTML & "<title>" & PageTitle & "</title>" & vbCrLf
283: HTML = HTML & "</head>" & vbCrLf
284: If AddBodyTags = True Then
285:
286: If ApplicationIsEvaluationVersion Then
287: If RandomNumber > 5 Then
288: HTML = HTML & "<BODY onLoad=""javascript:oOo();"">" & vbCrLf
289: HTML = HTML & "<script language=""JavaScript"">function oOo() {alert('Upgrade to the full version of the SQL Documentation Tool at " & ApplicationURL & "');}</script>" & vbCrLf
290: Else
291: HTML = HTML & "<body>" & vbCrLf
292: End If
293: Else
294: HTML = HTML & "<body>" & vbCrLf
295: End If
296:
297: HTML = HTML & "<h1>" & HTMLTitle & "</h1>" & vbCrLf
298: End If
299: HTML = HTML & "" & HTMLBody & "" & vbCrLf
300: If AddBodyTags = True Then
301: HTML = HTML & "</body>" & vbCrLf
302: End If
303: HTML = HTML & "</html>" & vbCrLf
304:
305: Dim FileSystemObject As New Scripting.FileSystemObject
306:
307: TextFile = FileSystemObject.CreateTextFile(FolderName & "/" & FileName, True, False)
308:
309: 'UPGRADE_WARNING: Couldn't resolve default property of object TextFile.Write. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
310: TextFile.Write(HTML)
311: 'UPGRADE_WARNING: Couldn't resolve default property of object TextFile.Close. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
312: TextFile.Close()
313:
314: 'UPGRADE_NOTE: Object FileSystemObject may not be destroyed until it is garbage collected. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1029"'
315: FileSystemObject = Nothing
316:
317: End Sub
318: Private Sub CreateFile(ByRef FolderName As String, ByRef FileName As String, ByRef FileBody As String)
319: Dim TextFile As Object
320:
321: Err.Clear()
322: On Error Resume Next
323:
324: Dim FileSystemObject As New Scripting.FileSystemObject
325:
326: TextFile = FileSystemObject.CreateTextFile(FolderName & "/" & FileName, True, False)
327:
328: 'UPGRADE_WARNING: Couldn't resolve default property of object TextFile.Write. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
329: TextFile.Write(FileBody)
330: 'UPGRADE_WARNING: Couldn't resolve default property of object TextFile.Close. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
331: TextFile.Close()
332:
333: 'UPGRADE_NOTE: Object FileSystemObject may not be destroyed until it is garbage collected. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1029"'
334: FileSystemObject = Nothing
335:
336: If Err.Number > 0 Then
337: FormMain.DefInstance.UpdateStatus(("Problem creating file " & FolderName & "/" & FileName))
338: Call AppendToLogFile(CurrentLogFileName, "ERROR: Problem creating the file: " & FolderName & "/" & FileName & vbCrLf)
339: Call AppendToLogFile(CurrentLogFileName, vbTab & "Details: (" & Err.Number & ") " & Err.Description & vbCrLf)
340: End If
341:
342: End Sub
343: Private Sub AppendFile(ByRef FolderName As String, ByRef FileName As String, ByRef FileBody As String)
344: Dim TextFile As Object
345:
346: Err.Clear()
347: On Error Resume Next
348:
349: Dim FileSystemObject As New Scripting.FileSystemObject
350:
351: TextFile = FileSystemObject.OpenTextFile(FolderName & "/" & FileName, Scripting.IOMode.ForAppending, False)
352:
353: 'UPGRADE_WARNING: Couldn't resolve default property of object TextFile.Write. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
354: TextFile.Write(FileBody)
355: 'UPGRADE_WARNING: Couldn't resolve default property of object TextFile.Close. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
356: TextFile.Close()
357:
358: 'UPGRADE_NOTE: Object FileSystemObject may not be destroyed until it is garbage collected. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1029"'
359: FileSystemObject = Nothing
360:
361: If Err.Number > 0 Then
362: 'FormMain.UpdateStatus ("Problem appending file " & FolderName & "/" & FileName)
363: Call AppendToLogFile(CurrentLogFileName, "ERROR: Problem appending the file: " & FolderName & "/" & FileName & vbCrLf)
364: Call AppendToLogFile(CurrentLogFileName, vbTab & "Details: (" & Err.Number & ") " & Err.Description & vbCrLf)
365: End If
366:
367: End Sub
368: Private Function GetDefaultPageHTML() As Object
369:
370: Dim HTML As String
371: HTML = ""
372:
373: HTML = HTML & "<frameset cols=""200,*"">" & vbCrLf
374: HTML = HTML & "<frame name=""functionsFrame"" target=""main"" src=""Databases.htm"">" & vbCrLf
375: HTML = HTML & "<frame name=""mainFrame"" src=""Introduction.htm"">" & vbCrLf
376: HTML = HTML & "<noframes>" & vbCrLf
377: HTML = HTML & "<body>" & vbCrLf
378: HTML = HTML & "<p><a href=""Databases.htm"" title=""Databases"">Databases</a></p>" & vbCrLf
379: HTML = HTML & "</body>" & vbCrLf
380: HTML = HTML & "</noframes>" & vbCrLf
381: HTML = HTML & "</frameset>" & vbCrLf
382:
383: 'UPGRADE_WARNING: Couldn't resolve default property of object GetDefaultPageHTML. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
384: GetDefaultPageHTML = HTML
385:
386: End Function
387: 'Builds the left hand frame
388: Private Function GetDatabaseListPageHTML() As Object
389:
390: Dim HTML As String
391: HTML = ""
392:
393: Dim RS As New ADODB.Recordset
394: Dim DataConnection As New ADODB.Connection
395: Dim SQL As String
396: Dim ConnectionID As Integer
397: Dim DatabaseID As Integer
398: Dim DatabaseName As String
399: Dim DatabaseServer As String
400: Dim TextReportsLinks As String
401: Dim PreviousDatabaseServer As String
402: Dim IsFirstDatabase As Boolean
403: Dim DTSLink As String
404: Dim JobLink As String
405:
406: SQL = "SELECT t_Databases.*, t_Connections.ConnectionID, t_Connections.DatabaseServer "
407: SQL = SQL & "FROM (t_Parses "
408: SQL = SQL & "INNER JOIN t_Databases on t_Parses.fk_ProjectID = t_Databases.fk_ProjectID) "
409: SQL = SQL & "INNER JOIN t_Connections on t_Databases.fk_ConnectionID = t_Connections.ConnectionID "
410: SQL = SQL & "WHERE t_Parses.ParseID = " & DocParseID & " "
411: SQL = SQL & "ORDER BY t_Connections.DatabaseServer"
412:
413: RS = DataStore.GetRecordSet(SQL)
414:
415: HTML = "" 'HTML & "<h2>Database Documentation Summary</h2>" & vbCrLf
416: TextReportsLinks = "Text Reports:<br>"
417: PreviousDatabaseServer = ""
418: IsFirstDatabase = True
419:
420: Do While Not RS.EOF
421:
422: DatabaseID = RS.Fields("DatabaseID").Value
423: ConnectionID = RS.Fields("ConnectionID").Value
424: DatabaseName = RS.Fields("DatabaseName").Value
425: DatabaseServer = RS.Fields("DatabaseServer").Value
426:
427: If DatabaseServer <> PreviousDatabaseServer Then
428: If IsFirstDatabase = False Then
429: HTML = HTML & DTSLink
430: HTML = HTML & JobLink
431: HTML = HTML & "</p>" & vbCrLf
432: End If
433:
434: HTML = HTML & "<p>" & DatabaseServer & "<br>" & vbCrLf
435: Else
436: HTML = HTML & "<br>" & vbCrLf
437: End If
438:
439: HTML = HTML & " <a href=""Database_" & DatabaseID & ".htm"" target=""mainFrame"">" & vbCrLf
440: HTML = HTML & DatabaseName & "</a><br>" & vbCrLf
441:
442: HTML = HTML & " <a href=""Database_" & DatabaseID & "_Tables.htm"" target=""mainFrame"">" & vbCrLf
443: HTML = HTML & "Tables</a><br>" & vbCrLf
444:
445: HTML = HTML & " <a href=""Database_" & DatabaseID & "_Views.htm"" target=""mainFrame"">" & vbCrLf
446: HTML = HTML & "Views</a><br>" & vbCrLf
447:
448: HTML = HTML & " <a href=""Database_" & DatabaseID & "_StoredProcedures.htm"" target=""mainFrame"">" & vbCrLf
449: HTML = HTML & "Stored Procedures</a><br>" & vbCrLf
450:
451: HTML = HTML & " <a href=""Database_" & DatabaseID & "_Triggers.htm"" target=""mainFrame"">" & vbCrLf
452: HTML = HTML & "Triggers</a><br>" & vbCrLf
453:
454: HTML = HTML & " <a href=""Database_" & DatabaseID & "_Indexes.htm"" target=""mainFrame"">" & vbCrLf
455: HTML = HTML & "Indexes</a><br>" & vbCrLf
456:
457: HTML = HTML & " <a href=""Database_" & DatabaseID & "_FullTextCatalogs.htm"" target=""mainFrame"">" & vbCrLf
458: HTML = HTML & "Full-Text Catalogs</a><br>" & vbCrLf
459:
460: If CurrentProjectDocumentDTSPackages Then
461: DTSLink = "<br> <a href=""Connection_" & ConnectionID & "_DTSPackages.htm"" target=""mainFrame"">" & vbCrLf
462: DTSLink = DTSLink & "DTS Packages</a><br>" & vbCrLf
463: End If
464:
465: If CurrentProjectDocumentJobs Then
466: JobLink = " <a href=""Connection_" & ConnectionID & "_Jobs.htm"" target=""mainFrame"">" & vbCrLf
467: JobLink = JobLink & "Jobs</a><br>" & vbCrLf
468: End If
469:
470: 'If DatabaseServer <> PreviousDatabaseServer Then
471: 'HTML = HTML & DTSLink
472: 'End If
473:
474: 'HTML = HTML & "</p>" & vbCrLf
475:
476: 'Build start of text file for each database
477: If MakeTextFile Then
478:
479: Call CreateFile(DocFolderPath, CurrentProjectName & "_" & DatabaseName & ".txt", UCase("Database " & DatabaseName) & vbCrLf & vbCrLf)
480:
481: TextReportsLinks = TextReportsLinks & " <a href=""" & CurrentProjectName & "_" & DatabaseName & ".txt"" title=""Text Report for Project " & CurrentProjectName & " database " & DatabaseName & """ target=""mainFrame"">"
482: TextReportsLinks = TextReportsLinks & DatabaseName
483: TextReportsLinks = TextReportsLinks & "</a>"
484: TextReportsLinks = TextReportsLinks & "<br>" & vbCrLf
485:
486: End If
487:
488: PreviousDatabaseServer = DatabaseServer
489: IsFirstDatabase = False
490:
491: 'If DatabaseServer <> PreviousDatabaseServer Or RS.EOF Then
492: ' HTML = HTML & DTSLink
493: 'End If
494:
495: RS.MoveNext()
496: Loop
497:
498: HTML = HTML & DTSLink
499: HTML = HTML & JobLink
500:
501: HTML = HTML & "<h2>Reports</h2>" & vbCrLf
502:
503: HTML = HTML & "<p>"
504:
505: HTML = HTML & "<a href=""Introduction.htm"" title=""HTML Report for Project " & CurrentProjectName & """ target=""mainFrame"">"
506: HTML = HTML & "HTML Report"
507: HTML = HTML & "</a>"
508: HTML = HTML & "<br>" & vbCrLf
509:
510: 'Link to HTML Help report if it was created
511: If MakeHTMLHelp Then
512: HTML = HTML & "<a href=""" & CurrentProjectName & ".chm"" title=""HTML Help Report for Project " & CurrentProjectName & """>"
513: HTML = HTML & "HTML Help Report"
514: HTML = HTML & "</a>"
515: HTML = HTML & "<br>" & vbCrLf
516: End If
517:
518: 'Link to RTF report if it was created
519: If MakeRTFFile Then
520: HTML = HTML & "<a href=""" & CurrentProjectName & ".rtf"" title=""RTF (Word compatible) Report for Project " & CurrentProjectName & """ target=""_blank"">"
521: HTML = HTML & "RTF (Word compatible) Report"
522: HTML = HTML & "</a>"
523: HTML = HTML & "<br>" & vbCrLf
524:
525: End If
526:
527: 'Link to text reports if they were created
528: If MakeTextFile Then
529:
530: HTML = HTML & TextReportsLinks
531: 'HTML = HTML & "<br>" & vbCrLf
532:
533:
534: End If
535:
536: HTML = HTML & "</p>" & vbCrLf
537:
538: 'Link to us
539: HTML = HTML & "<p><small>"
540: HTML = HTML & "Documentation generated by the "
541: HTML = HTML & "<a href=""" & ApplicationURL & "?V=" & ApplicationVersion & """ title=""" & ApplicationName & """ target=""_blank"">"
542: HTML = HTML & ApplicationName
543: HTML = HTML & "</a>"
544: HTML = HTML & "</small></p>" & vbCrLf
545:
546: 'UPGRADE_WARNING: Couldn't resolve default property of object GetDatabaseListPageHTML. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
547: GetDatabaseListPageHTML = HTML
548:
549: End Function
550: 'Note that this also builds the introduction page
551: Public Sub CreateDatabasePages()
552: Dim FullTextCatalogName As Object
553: Dim FullTextCatalogID As Object
554: Dim IndexName As Object
555: Dim IndexID As Object
556: Dim TriggerName As Object
557: Dim TriggerID As Object
558: Dim RSTriggers As Object
559: Dim StoredProcedureName As Object
560: Dim StoredProcedureID As Object
561: Dim ViewName As Object
562: Dim ViewID As Object
563: Dim RSViews As Object
564: Dim TableName As Object
565: Dim TableID As Object
566: Dim RSTables As Object
567:
568: Dim TablesHTML As String
569: TablesHTML = ""
570: Dim ViewsHTML As String
571: ViewsHTML = ""
572: Dim StoredProceduresHTML As String
573: StoredProceduresHTML = ""
574: Dim TriggersHTML As String
575: TriggersHTML = ""
576: Dim IndexesHTML As String
577: IndexesHTML = ""
578: Dim NumberOfTables As Integer
579: Dim NumberOfViews As Integer
580: Dim NumberOfStoredProcedures As Integer
581: Dim NumberOfTriggers As Integer
582: Dim NumberOfIndexes As Integer
583: Dim FullTextCatalogsHTML As String
584: Dim NumberOfFullTextCatalogs As Integer
585:
586: Dim RSDatabases As New ADODB.Recordset
587: Dim RSStoredProcedures As New ADODB.Recordset
588: Dim RSStoredProcedureColumns As New ADODB.Recordset
589: Dim RSFullTextCatalogs As New ADODB.Recordset
590: Dim RSIndexes As New ADODB.Recordset
591: Dim DataConnection As New ADODB.Connection
592: Dim SQL As String
593: Dim DatabaseID As Integer
594: Dim DatabaseName As String
595: Dim PageBody As String
596: Dim PageTitle As String
597:
598: Dim IntroductionPageBody As String
599:
600: SQL = "SELECT t_Databases.* "
601: SQL = SQL & "FROM t_Parses "
602: SQL = SQL & "INNER JOIN t_Databases on t_Parses.fk_ProjectID = t_Databases.fk_ProjectID "
603: SQL = SQL & "WHERE t_Parses.ParseID = " & DocParseID
604:
605: RSDatabases = DataStore.GetRecordSet(SQL)
606:
607: IntroductionPageBody = "<h2>Database Documentation Summary</h2>" & vbCrLf
608:
609: Do While Not RSDatabases.EOF
610:
611: DatabaseID = RSDatabases.Fields("DatabaseID").Value
612: DatabaseName = RSDatabases.Fields("DatabaseName").Value
613:
614: PageTitle = "Database " & DatabaseName
615: PageBody = ""
616:
617: IntroductionPageBody = IntroductionPageBody & "<h3>Database <a href=""Database_" & DatabaseID & ".htm"">" & DatabaseName & "</a></h3>" & vbCrLf
618:
619: 'Show list of tables in this database
620: If ApplicationIsEvaluationVersion Then
621: SQL = "SELECT TOP " & ApplicationEvaluationVersionItemLimit & " t_Tables.* "
622: Else
623: SQL = "SELECT t_Tables.* "
624: End If
625:
626: SQL = SQL & "FROM t_Tables "
627: SQL = SQL & "WHERE "
628: SQL = SQL & "fk_ParseID = " & DocParseID
629: SQL = SQL & " AND fk_DatabaseID = " & DatabaseID
630: RSTables = DataStore.GetRecordSet(SQL)
631:
632: TablesHTML = "<h2>Tables</h2>" & vbCrLf
633: NumberOfTables = 0
634:
635: 'UPGRADE_WARNING: Couldn't resolve default property of object RSTables.EOF. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
636: Do While Not RSTables.EOF
637:
638: 'UPGRADE_WARNING: Couldn't resolve default property of object RSTables.Fields. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
639: 'UPGRADE_WARNING: Couldn't resolve default property of object TableID. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
640: TableID = RSTables.Fields("TableID").Value
641: 'UPGRADE_WARNING: Couldn't resolve default property of object RSTables.Fields. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
642: 'UPGRADE_WARNING: Couldn't resolve default property of object TableName. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
643: TableName = RSTables.Fields("TableName").Value
644: 'UPGRADE_WARNING: Couldn't resolve default property of object TableID. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
645: TablesHTML = TablesHTML & "<a href=""Database_" & DatabaseID & "_Table_" & TableID & ".htm"" target=""mainFrame"">" & vbCrLf
646: 'UPGRADE_WARNING: Couldn't resolve default property of object TableName. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
647: TablesHTML = TablesHTML & "" & TableName & "</a><br>" & vbCrLf
648:
649: NumberOfTables = NumberOfTables + 1
650:
651: 'UPGRADE_WARNING: Couldn't resolve default property of object RSTables.MoveNext. Click for more: 'ms-help://MS.VSCC.2003/commoner/redir/redirect.htm?keyword="vbup1037"'
652: RSTables.MoveNext()
653: Loop
654:
655: If NumberOfTables = 0 Then
656: TablesHTML = TablesHTML & "No tables were found."
657: IntroductionPageBody = IntroductionPageBody & "Number of Tables: " & NumberOfTables & "<br>" & vbCrLf
658: Else
659: IntroductionPageBody = IntroductionPageBody & "Number of Tables: " & NumberOfTables & " [ <a href=""Database_" & DatabaseID & "_Tables.htm"">View Tables</a> ]<br>" & vbCrLf
660: End If
661:
662:
663:
664: PageBody = PageBody & TablesHTML
665:
666: 'Show a list of views in this database
667: If ApplicationIsEvaluationVersion Then
668: SQL = "SELECT TOP " & ApplicationEvaluationVersionItemLimit & " t_Views.* "
669: Else
670: SQL = "SELECT t_Views.* "
671: End If
672:
673: SQL = SQL & "FROM t_Views "
674: SQL = SQL & "WHERE "
675: SQL = SQL & "fk_ParseID = " & DocParseID
676: &nbs