THEO TODMAN’S BRIDGE WEBSITES CODE PAGES



This Page provides a jumping-off point for the VBA Code that generates my Bridge Websites.

Table of Code Documentation Location 9 (13 items)

cmdCloseForm_ClickcmdHuttonConversion_ClickcmdHuttonHandicap_ClickcmdHuttonImprovers_Click
cmdJointProjectConversion_ClickcmdJointProjectPlayerSearch_ClickcmdMasterpoints_ClickcmdResults_Click
cmdResultsExport_ClickcmdResultsList_ClickMountnessing_RecursionCategorise_Hands
CreateTableWebpages...

To access information, click on one of the links in the table above.

Go to top of page




Source Code of: Categorise_Hands
Procedure Type: Public Sub
Module: HandDealing
Lines of Code: 117
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Categorise_Hands()
0002Dim rsTableControl As Recordset
0003Dim Who As String
0004 DoCmd.RunSQL ("DELETE Hand_Type_Relations.* FROM Hand_Type_Relations;")
0005'Read Database Records
0006 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Hands.* FROM Hands;")
0007If Not rsTableControl.EOF Then
0008 rsTableControl.MoveFirst
0009End If
0010Do While Not rsTableControl.EOF
0011 HandNo = rsTableControl.Fields(0)
0012 N_Spades = rsTableControl.Fields(1)
0013 N_Hearts = rsTableControl.Fields(2)
0014 N_Clubs = rsTableControl.Fields(3)
0015 N_Diamonds = rsTableControl.Fields(4)
0016 E_Spades = rsTableControl.Fields(5)
0017 E_Hearts = rsTableControl.Fields(6)
0018 E_Clubs = rsTableControl.Fields(7)
0019 E_Diamonds = rsTableControl.Fields(8)
0020 S_Spades = rsTableControl.Fields(9)
0021 S_Hearts = rsTableControl.Fields(10)
0022 S_Clubs = rsTableControl.Fields(11)
0023 S_Diamonds = rsTableControl.Fields(12)
0024 W_Spades = rsTableControl.Fields(13)
0025 W_Hearts = rsTableControl.Fields(14)
0026 W_Clubs = rsTableControl.Fields(15)
0027 W_Diamonds = rsTableControl.Fields(16)
0028 N_Points = rsTableControl.Fields(17)
0029 E_Points = rsTableControl.Fields(18)
0030 S_Points = rsTableControl.Fields(19)
0031 W_Points = rsTableControl.Fields(20)
0032 N_Distribution = rsTableControl.Fields(21)
0033 E_Distribution = rsTableControl.Fields(22)
0034 S_Distribution = rsTableControl.Fields(23)
0035 W_Distribution = rsTableControl.Fields(24)
0036 N_Distribution_Long = rsTableControl.Fields(31)
0037 E_Distribution_Long = rsTableControl.Fields(32)
0038 S_Distribution_Long = rsTableControl.Fields(33)
0039 W_Distribution_Long = rsTableControl.Fields(34)
0040 'Slam Hands
0041 Who = Slam_Hand
0042 If Who <> "No" Then
0043 OK = Output_Relation(9, Who)
0044 End If
0045 'Game Hands
0046 Who = Game_Hand
0047 If Who <> "No" Then
0048 OK = Output_Relation(10, Who)
0049 End If
0050 'Weak 2s
0051 Who = Weak_Two
0052 If Who <> "" Then
0053 OK = Output_Relation(2, Who)
0054 End If
0055 'Pre-Empts
0056 Who = PreEmpt
0057 If Who <> "" Then
0058 OK = Output_Relation(3, Who)
0059 End If
0060 '2 Clubs
0061 Who = Two_Club
0062 If Who <> "" Then
0063 OK = Output_Relation(4, Who)
0064 End If
0065 '2 Diamonds
0066 Who = Two_Diamond
0067 If Who <> "" Then
0068 OK = Output_Relation(5, Who)
0069 End If
0070 '1 NT
0071 Who = One_NT
0072 If Who <> "" Then
0073 OK = Output_Relation(1, Who)
0074 End If
0075 'Strong 1 NT
0076 Who = Strong_NT
0077 If Who <> "" Then
0078 OK = Output_Relation(12, Who)
0079 End If
0080 '2 NT
0081 Who = Two_NT
0082 If Who <> "" Then
0083 OK = Output_Relation(6, Who)
0084 End If
0085 '4-4-4-1
0086 Who = FFF1_Hands
0087 If Who <> "" Then
0088 OK = Output_Relation(11, Who)
0089 End If
0090 'Strong Diamond 2C/2D
0091 Who = StrongD2Minor
0092 If Who <> "" Then
0093 OK = Output_Relation(13, Who)
0094 End If
0095 'Strong Diamond 1D
0096 Who = StrongD1D
0097 If Who <> "" Then
0098 OK = Output_Relation(14, Who)
0099 End If
0100 'Strong Diamond 2NT
0101 Who = StrongD2NT
0102 If Who <> "" Then
0103 OK = Output_Relation(15, Who)
0104 End If
0105 'Strong Diamond 1C
0106 Who = StrongD1C
0107 If Who <> "" Then
0108 OK = Output_Relation(16, Who)
0109 End If
0110 'Strong Diamond 1 Major
0111 Who = StrongD1Major
0112 If Who <> "" Then
0113 OK = Output_Relation(17, Who)
0114 End If
0115 rsTableControl.MoveNext
0116Loop
0117End Sub

Procedures Calling This Procedure (Categorise_Hands) Procedures Called By This Procedure (Categorise_Hands) Tables / Queries / Fragments Directly Used By This Procedure (Categorise_Hands) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdCloseForm_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 3

Line-No. / Ref.Code Line
0001Private Sub cmdCloseForm_Click()
0002DoCmd.Quit
0003End Sub

Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdHuttonConversion_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 3

Line-No. / Ref.Code Line
0001Private Sub cmdHuttonConversion_Click()
0002 Conversion_Control
0003End Sub

Procedures Called By This Procedure (cmdHuttonConversion_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdHuttonHandicap_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 3

Line-No. / Ref.Code Line
0001Private Sub cmdHuttonHandicap_Click()
0002 Web_Page_Control_Handicap
0003End Sub

Procedures Called By This Procedure (cmdHuttonHandicap_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdHuttonImprovers_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 3

Line-No. / Ref.Code Line
0001Private Sub cmdHuttonImprovers_Click()
0002 Web_Page_Control_Improvers
0003End Sub

Procedures Called By This Procedure (cmdHuttonImprovers_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdJointProjectConversion_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 4

Line-No. / Ref.Code Line
0001Private Sub cmdJointProjectConversion_Click()
0002 Check_EBU_Members_Downloaded
0003 Import_Control
0004End Sub

Procedures Called By This Procedure (cmdJointProjectConversion_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdJointProjectPlayerSearch_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 12

Line-No. / Ref.Code Line
0001Private Sub cmdJointProjectPlayerSearch_Click()
0002 DoCmd.Close acTable, "Joint_Project_Player_Choice"
0003 DoCmd.OpenTable "Joint_Project_Player_Choice"
0004 DoCmd.Close acQuery, "Joint_Project_Player_List"
0005 DoCmd.OpenQuery ("Joint_Project_Player_List")
0006 DoCmd.Close acQuery, "Joint_Project_Player_Crosstab"
0007 DoCmd.OpenQuery ("Joint_Project_Player_Crosstab")
0008 DoCmd.Close acQuery, "Joint_Project_Player_Crosstab_Count"
0009 DoCmd.OpenQuery ("Joint_Project_Player_Crosstab_Count")
0010 DoCmd.Close acQuery, "Joint_Project_Choice_Club_Sesions_Crosstab"
0011 DoCmd.OpenQuery ("Joint_Project_Choice_Club_Sesions_Crosstab")
0012End Sub

Tables / Queries / Fragments Directly Used By This Procedure (cmdJointProjectPlayerSearch_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdMasterpoints_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 17

Line-No. / Ref.Code Line
0001Private Sub cmdMasterpoints_Click()
0002If MsgBox("Do you want to output the ECBA Master Points web-pages?", vbYesNo) = vbYes Then
0003Else
0004 MsgBox ("Click another button then!")
0005 End
0006End If
0007 OK = Web_Page_Control_EBU_Masterpoints("ECBA", "LPs", 9999, "ECBA", "No")
0008 OK = Web_Page_Control_EBU_Masterpoints("Club", "LPs", 9999, "ECBA", "No")
0009 OK = Web_Page_Control_EBU_Masterpoints("Club", "LPs", 9999, "ECBA", "Yes")
0010 OK = Web_Page_Control_EBU_Masterpoints("ECBA", "LPs", 2016, "ECBA", "No")
0011 OK = Web_Page_Control_EBU_Masterpoints("Club", "LPs", 2016, "ECBA", "No")
0012 OK = Web_Page_Control_EBU_Masterpoints("ECBA", "GPs", 9999, "ECBA", "No")
0013 OK = Web_Page_Control_EBU_Masterpoints("Club", "GPs", 9999, "ECBA", "No")
0014 OK = Web_Page_Control_EBU_Masterpoints("ECBA", "GPs", 2016, "ECBA", "No")
0015 OK = Web_Page_Control_EBU_Masterpoints("Club", "GPs", 2016, "ECBA", "No")
0016MsgBox ("Masterpoints Lists Output OK")
0017End Sub

Procedures Called By This Procedure (cmdMasterpoints_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdResults_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 6

Line-No. / Ref.Code Line
0001Private Sub cmdResults_Click()
0002 DoCmd.Close acTable, "Theo_Results"
0003 DoCmd.OpenTable "Theo_Results"
0004 DoCmd.Close acTable, "Results_Links"
0005 DoCmd.OpenTable "Results_Links"
0006End Sub

Tables / Queries / Fragments Directly Used By This Procedure (cmdResults_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdResultsExport_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 56
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdResultsExport_Click()
0002Dim rsTableControl As Recordset
0003Dim Wanted As Boolean
0004If MsgBox("Output Theo's Consolidated Bridge Results Webpages?", vbYesNo) <> vbYes Then
0005 Exit Sub
0006Else
0007 DoCmd.OpenTable ("Reporting_Periods_Bridge")
0008 If MsgBox("Have you set the Reporting Periods?", vbYesNo) <> vbYes Then
0009 Exit Sub
0010 Else
0011 DoCmd.Close acTable, "Reporting_Periods_Bridge"
0012 End If
0013End If
0014 Results_Export
0015 Stats_Export
0016 Set rsTableControl = CurrentDb.OpenRecordset("SELECT * FROM Reporting_Periods_Bridge ORDER BY Period;")
0017rsTableControl.MoveFirst
0018strPeriod = rsTableControl.Fields(0)
0019Start_Date = rsTableControl.Fields(1)
0020Wanted = rsTableControl.Fields(2)
0021File_Suffix_Previous = ""
0022rsTableControl.MoveNext
0023Do While Not rsTableControl.EOF
0024 'Set the Parameters ... Temporary fudge ...?
0025 End_Date = rsTableControl.Fields(1)
0026 File_Suffix_Next = rsTableControl.Fields(0)
0027 If Wanted = True Then
0028 Quarterly = True
0029 Consolidated_Results_Export
0030 Quarterly = False
0031 Consolidated_Results_Export
0032 End If
0033 File_Suffix_Previous = strPeriod
0034 strPeriod = rsTableControl.Fields(0)
0035 Start_Date = rsTableControl.Fields(1)
0036 Wanted = rsTableControl.Fields(2)
0037 rsTableControl.MoveNext
0038Loop
0039'Last output ...
0040If Wanted = True Then
0041 End_Date = Now() + 2
0042 File_Suffix_Next = ""
0043 Quarterly = True
0044 Consolidated_Results_Export
0045 Quarterly = False
0046 Consolidated_Results_Export
0047End If
0048'Repeat
0049 Results_Export
0050 Stats_Export
0051 Results_Export_Sorted
0052 NGS_Calculator
0053 DoCmd.Close acQuery, "NGS_Checker"
0054 DoCmd.OpenQuery ("NGS_Checker")
0055MsgBox ("Theo's Consolidated Bridge Results Webpages Output OK")
0056End Sub

Procedures Called By This Procedure (cmdResultsExport_Click) Tables / Queries / Fragments Directly Used By This Procedure (cmdResultsExport_Click) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: cmdResultsList_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 4

Line-No. / Ref.Code Line
0001Private Sub cmdResultsList_Click()
0002 DoCmd.Close acQuery, "Theo_Sessions_List"
0003 DoCmd.OpenQuery "Theo_Sessions_List"
0004End Sub

Tables / Queries / Fragments Directly Used By This Procedure (cmdResultsList_Click) Go To Top of This Page
Link to VBA Code Control Page



Source Code of: CreateTableWebpages
Procedure Type: Public Sub
Module: Documentation
Lines of Code: 155
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub CreateTableWebpages()
0002Dim rsTableControl As Recordset
0003Dim strControlQuery As String
0004Dim strLine As String
0005Dim iTableColumns As Integer
0006Dim i As Long
0007Dim strFileSuffix As String
0008Dim Procedure_Type As String
0009Dim Heading As String
0010Dim rsTableToRead As Recordset
0011Dim rsTableToRead2 As Recordset
0012Dim rsProcedure_Location As Recordset
0013Dim Procedure_Location As Integer
0014Dim This_Location As Integer
0015Dim This_Object As String
0016Dim This_Object_Count As String
0017Dim This_Line As Integer
0018Dim Last_Location As Integer
0019Dim Last_Object As String
0020Dim Last_Line As Integer
0021Dim strMainText As String
0022Dim strLinks As String
0023Dim strOutputFileShort_Saved As String
0024'Create the Table Detail File
0025'Read the data
0026 strDataQuery = "SELECT Table_Definitions.* FROM Table_Definitions ORDER BY Table_Definitions.Table_Name;"
0027Set rsTableToRead = CurrentDb.OpenRecordset(strDataQuery)
0028rsTableToRead.MoveFirst
0029'Create File
0030strOutputFileShort = SubSystem & "Documentation_Code_Tables"
0031strOutputFileShort_Saved = strOutputFileShort
0032Set tsTextFile = fsoTextFile2.CreateTextFile(strOutputFolder & strOutputFileShort & ".htm", True, True)
0033'Create Page Header
0034 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Header"")) ORDER BY Website_Control.Line;"
0035Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0036rsTableControl.MoveFirst
0037Do While Not rsTableControl.EOF
0038 strLine = rsTableControl.Fields(0) & ""
0039 tsTextFile.WriteLine strLine
0040 rsTableControl.MoveNext
0041Loop
0042'Create Jump Table
0043iTableColumns = 4
0044Procedure_Type = "Table"
0045Heading = "Tables"
0046Procedure_Location = 0
0047 OK = CreateDocumentationJumpTables(Procedure_Type, Heading, iTableColumns, Procedure_Location)
0048Do While Not rsTableToRead.EOF
0049 'Create Main Text
0050 For i = 1 To rsTableToRead.Fields.Count
0051 Heading = rsTableToRead.Fields(i - 1)
0052 If i = 1 Then
0053 strLine = "<A Name =""" & Heading & """></A>" & "<B>" & rsTableToRead.Fields(i - 1).Name & ": " & Heading & "</B><BR>"
0054 Else
0055 strLine = strLine & "<B>" & rsTableToRead.Fields(i - 1).Name & ":</B> " & Heading & "<BR>"
0056 End If
0057 Next i
0058 strMainText = strLine
0059 strLine = strLine & "<b>Link To Column Definitions: </b><A HREF=""" & SubSystem & "Documentation_Tables_" & rsTableToRead.Fields(0) & ".htm"">" & rsTableToRead.Fields(0) & "</A><br><br>"
0060 tsTextFile.WriteLine strLine
0061 'Create Query Links In
0062 strLine = ""
0063 strDataQuery = "SELECT Query_Links_Table.*, Query_Definitions.Query_Type FROM Query_Links_Table LEFT JOIN Query_Definitions ON Query_Links_Table.Object_1 = Query_Definitions.Query_Name WHERE (((Query_Links_Table.Object_2) = """ & rsTableToRead.Fields(0).Value & """) AND Query_Links_Table.Object_1_Type = ""Q"") ORDER BY Query_Links_Table.Object_1_Type, Query_Links_Table.Object_1, Query_Links_Table.Code_Line;"
0064 Set rsTableToRead2 = CurrentDb.OpenRecordset(strDataQuery)
0065 If Not rsTableToRead2.EOF Then
0066 rsTableToRead2.MoveFirst
0067 strLine = strLine & "<U><B>Queries Using this Table</U></B><UL>"
0068 Do While Not rsTableToRead2.EOF
0069 strLine = strLine & "<LI><A HREF=""" & SubSystem & "Documentation_Code_Queries_" & rsTableToRead2.Fields(5) & ".htm#" & rsTableToRead2.Fields(0) & """>" & rsTableToRead2.Fields(0) & "</A>" & "</LI>"
0070 rsTableToRead2.MoveNext
0071 Loop
0072 strLine = strLine & "</UL>"
0073 End If
0074 'Create Code Links In
0075 strDataQuery = "SELECT Query_Links_Table.*, Query_Definitions.Query_Type FROM Query_Links_Table LEFT JOIN Query_Definitions ON Query_Links_Table.Object_1 = Query_Definitions.Query_Name WHERE (((Query_Links_Table.Object_2) = """ & rsTableToRead.Fields(0).Value & """) AND Query_Links_Table.Object_1_Type = ""C"") ORDER BY Query_Links_Table.Object_1_Type, Query_Links_Table.Object_1, Query_Links_Table.Code_Line;"
0076 Set rsTableToRead2 = CurrentDb.OpenRecordset(strDataQuery)
0077 If Not rsTableToRead2.EOF Then
0078 rsTableToRead2.MoveFirst
0079 strLine = strLine & "<U><B>Code Using this Table</U></B><UL>"
0080 Last_Object = "zzzz"
0081 This_Object_Count = 0
0082 Do While Not rsTableToRead2.EOF
0083 This_Object = rsTableToRead2.Fields(0)
0084 'Find the Code_Location ...
0085 Set rsProcedure_Location = CurrentDb.OpenRecordset("Select Code_Location.Code_Location FROM Code_Location WHERE Code_Location.Procedure_Name = """ & This_Object & """;")
0086 If rsProcedure_Location.EOF Then
0087 This_Location = 1 'Should not occur!
0088 MsgBox ("Code Location problem in CreateTableWebpages - " & This_Object & " assigned to Location 1")
0089 Else
0090 rsProcedure_Location.MoveFirst
0091 This_Location = rsProcedure_Location.Fields(0)
0092 End If
0093 This_Line = rsTableToRead2.Fields(4)
0094 If Last_Object = This_Object Then
0095 If This_Object_Count = 1 Then
0096 strLine = strLine & "<LI>" & Last_Object & " (From Lines <A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>, "
0097 Else
0098 strLine = strLine & "<A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>, "
0099 End If
0100 This_Object_Count = This_Object_Count + 1
0101 Else
0102 If Last_Object <> "zzzz" Then
0103 If This_Object_Count = 1 Then
0104 strLine = strLine & "<LI>" & Last_Object & " (From Line <A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0105 Else
0106 strLine = strLine & "<A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)"
0107 End If
0108 End If
0109 This_Object_Count = 1
0110 End If
0111 rsTableToRead2.MoveNext
0112 Last_Location = This_Location
0113 Last_Object = This_Object
0114 Last_Line = This_Line
0115 Loop
0116 'Last line
0117 If Last_Object <> "zzzz" Then
0118 If This_Object_Count = 1 Then
0119 strLine = strLine & "<LI>" & Last_Object & " (From Line <A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0120 Else
0121 strLine = strLine & "<A HREF=""" & SubSystem & "Documentation_Code_" & Last_Location & ".htm#" & Last_Object & "_" & Last_Line & """>" & Last_Line & "</A>)</LI>"
0122 End If
0123 End If
0124 strLine = strLine & "</UL>"
0125 End If
0126 strLinks = strLine
0127 'Create link to top of page
0128 strLine = strLine & "<A HREF=""#Top"">Go To Top of This Page</A><br>"
0129 'Create link to main code jump-table
0130 strLine = strLine & "<A HREF=""" & SubSystem & "DocumentationControl.htm"">Link to VBA Code Control Page</A><br>"
0131 'Rule off ready for next procedure
0132 strLine = strLine & "<BR><HR>"
0133 tsTextFile.WriteLine strLine
0134 strLine = ""
0135 'Regenerate the field-list page (if changed since last run)
0136 If rsTableToRead.Fields(3) > Documentation_Last_Run Or Document_Tables_Full = True Then
0137 OK = Document_Object_Columns(rsTableToRead.Fields(0), "Table", SubSystem & "Documentation_Code_Tables", strMainText, strLinks)
0138 End If
0139 rsTableToRead.MoveNext
0140Loop
0141'Finish File
0142'Page Footer
0143 strControlQuery = "SELECT Website_Control.Line_Value FROM Website_Control WHERE (((Website_Control.Web_Page) = """ & strControlTable & """) And ((Website_Control.Section) = ""Footer"")) ORDER BY Website_Control.Line;"
0144Set rsTableControl = CurrentDb.OpenRecordset(strControlQuery)
0145rsTableControl.MoveFirst
0146Do While Not rsTableControl.EOF
0147 strLine = rsTableControl.Fields(0)
0148 OK = Replace_Timestamp(strLine)
0149 tsTextFile.WriteLine strLine
0150 rsTableControl.MoveNext
0151Loop
0152'Copy to Transfer
0153strFileSuffix = strOutputFileShort_Saved
0154 OK = CopyToTransfer(strFolder, strFileSuffix & ".htm")
0155End Sub

Procedures Calling This Procedure (CreateTableWebpages) Procedures Called By This Procedure (CreateTableWebpages) Tables / Queries / Fragments Directly Used By This Procedure (CreateTableWebpages) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



Source Code of: Mountnessing_Recursion
Procedure Type: Public Function
Module: Mountnessing
Lines of Code: 110
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Mountnessing_Recursion(DirectoryName, Directory_Out, Depth)
0002Dim strLine As String
0003Dim InFile As String
0004Dim MainFolder
0005Dim FileCollection
0006Dim File
0007Dim File_Name As String
0008Dim strInputFolder As String
0009Dim strOutputFolder As String
0010Dim strFolder As String
0011Dim strOutputFileShort As String
0012Dim strFilename As String
0013Dim Depth_Local As Integer
0014Dim Prefix As String
0015Dim i As Integer
0016Depth_Local = Depth
0017Prefix = ""
0018For i = 1 To Depth_Local
0019 Prefix = Prefix & "../"
0020Next i
0021strInputFolder = DirectoryName
0022strOutputFolder = Directory_Out
0023Set MainFolder = fso.GetFolder(strInputFolder)
0024Set FileCollection = MainFolder.Files
0025If Dir(Directory_Out) <> "" Then
0026Else
0027 On Error Resume Next
0028 fso.CreateFolder (Directory_Out)
0029End If
0030For Each File In FileCollection
0031 File_Name = File.Name
0032 If Left(File_Name, 1) <> "." Then
0033 If Dir(strOutputFolder & File_Name) <> "" Then 'If we already have a file in the transfer directory, then zap it
0034 Kill strOutputFolder & File_Name
0035 End If
0036 End If
0037 Files_Processed = Files_Processed + 1
0038 If Right(File_Name, 4) = ".htm" Or Right(File_Name, 6) = ".shtml" Then
0039 strFolder = strOutputFolder
0040 strFilename = File_Name
0041 Set tsTextFile = fsoTextFile.CreateTextFile(strFolder & strFilename, True)
0042 InFile = strInputFolder & File_Name
0043 Set tsTextFileIn = fso.OpenTextFile(InFile, 1, False, 0) 'Open the file
0044 strLine = tsTextFileIn.ReadLine
0045 Do Until tsTextFileIn.AtEndOfStream
0046 strLine = tsTextFileIn.ReadLine
0047 strLine = Replace(strLine, Old_SiteRef, New_SiteRef)
0048 strLine = Replace(strLine, Old_SiteRef & "/", New_SiteRef)
0049 strLine = Replace(strLine, "<a href=""/", "<a href=""")
0050 strLine = Replace(strLine, "<BASE HREF="""" target=""_blank"">", "")
0051 'Fix SSL
0052 If InStr(strLine, "<!--") > 0 Then
0053 If InStr(strLine, "timefmt") > 0 Then
0054 strLine = ""
0055 Else
0056 If InStr(strLine, "title.shtml") > 0 Then
0057 strLine = strTitle
0058 Else
0059 If InStr(strLine, "title2.shtml") > 0 Then
0060 strLine = strTitle2
0061 Else
0062 If InStr(strLine, "flastmod") > 0 Then
0063 strLine = ""
0064 Else
0065 If InStr(strLine, "title_t.shtml") > 0 Then
0066 strLine = strTitle_t
0067 Else
0068 If InStr(strLine, "title2_t.shtml") > 0 Then
0069 strLine = strTitle2_t
0070 Else
0071 If InStr(strLine, "title_p.shtml") > 0 Then
0072 strLine = strTitle_p
0073 Else
0074 If InStr(strLine, "title2_p.shtml") > 0 Then
0075 strLine = strTitle2_p
0076 Else
0077 If InStr(strLine, ".shtml") > 0 Then
0078 Debug.Print strLine
0079 End If
0080 End If
0081 End If
0082 End If
0083 End If
0084 End If
0085 End If
0086 End If
0087 End If
0088 End If
0089 strLine = Replace(strLine, "href=""", "href=""" & Prefix)
0090 strLine = Replace(strLine, "href=""" & Prefix & "http", "href=""http")
0091 strLine = Replace(strLine, "src=""", "src=""" & Prefix)
0092 tsTextFile.WriteLine strLine
0093 Loop
0094 Else
0095 If Left(File_Name, 1) <> "." Then
0096 fso.CopyFile strInputFolder & File_Name, strOutputFolder & File_Name 'Copy to the output directory
0097 End If
0098 End If
0099Next File
0100Recursion:
0101Set FileCollection = MainFolder.SubFolders
0102For Each File In FileCollection
0103 File_Name = File.Name
0104 strInputFolder = DirectoryName & File_Name & "\"
0105 strOutputFolder = Directory_Out & File_Name & "\"
0106 'Recursion ...
0107 OK = Mountnessing_Recursion(strInputFolder, strOutputFolder, Depth_Local + 1)
0108Next File
0109Set FileCollection = Nothing
0110End Function

Procedures Calling This Procedure (Mountnessing_Recursion) Procedures Called By This Procedure (Mountnessing_Recursion) Go To Start of This Procedure
Go To Top of This Page
Link to VBA Code Control Page



© Theo Todman, June 2007 - December 2019 Please address any comments on this page to theo@theotodman.com. File output:
Website Maintenance Dashboard
Return to Top of this Page Return to Theo Todman's Bridge Page Return to Theo Todman's Home Page