THEO TODMAN’S WEBSITE CODE PAGES


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

Table of Code Documentation Location 43 (9 items)

Core_URL_GenFunctor_05Prune_Raw_LinksRemove_Hyperlinks
TrimBranchesZap_Cross_ReferencesMonthly_Report_Note1024_UpdatePapersToNotes_Prelims
Pianola_Check...

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

Go to top of page



Source Code of: Core_URL_Gen
Procedure Type: Public Function
Module: Spider
Lines of Code: 43
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Core_URL_Gen(In_URL)
0002Dim In_URL_Local As String
0003Dim URL_Segment As String
0004Dim srtReturned As String
0005Dim i As Integer
0006Dim j As Integer
0007Dim k As Integer
0008Dim Numeric_Segment As Boolean
0009In_URL_Local = In_URL
0010i = 1
0011srtReturned = ""
0012j = InStr(i, In_URL_Local, ".")
0013URL_Segment = ""
0014Do While j > 0 Or URL_Segment <> ""
0015 If j > 0 Then
0016 URL_Segment = Mid(In_URL_Local, i, j - i)
0017 End If
0018 Numeric_Segment = False
0019 For k = 1 To Len(URL_Segment)
0020 If Mid(URL_Segment, k, 1) >= 0 And Mid(URL_Segment, k, 1) <= 9 Then
0021 Numeric_Segment = True
0022 k = Len(URL_Segment) + 1
0023 End If
0024 Next k
0025 If Numeric_Segment = False Then
0026 If srtReturned <> "" Then
0027 srtReturned = srtReturned & "."
0028 End If
0029 srtReturned = srtReturned & URL_Segment
0030 End If
0031 If j > 0 Then
0032 i = j + 1
0033 j = InStr(i, In_URL_Local, ".")
0034 If j = 0 Then
0035 URL_Segment = Mid(In_URL_Local, i, Len(In_URL_Local))
0036 End If
0037 Else
0038 URL_Segment = ""
0039 End If
0040Loop
0041'Debug.Print Now(); "- URL: " & In_URL_Local; " Returned: " & srtReturned
0042Core_URL_Gen = srtReturned
0043End Function

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


Source Code of: Functor_05
Procedure Type: Public Function
Module: Functors
Lines of Code: 70
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_05(strQuery, strNote_Text)
0002'Development Log report - Completed Items - Category Sequence
0003Dim rs As Recordset
0004Dim strNote_Text_Local
0005Dim Implementation_Period As String
0006Dim Category As String
0007Dim Development As String
0008Dim Category_Saved As String
0009Dim strCategory_Text As String
0010Dim Implementation_Period_Saved As String
0011Dim strImplementation_Period_Text As String
0012strNote_Text_Local = ""
0013Category_Saved = "ZZZZZ"
0014strCategory_Text = ""
0015Implementation_Period_Saved = "ZZZZ"
0016strImplementation_Period_Text = ""
0017Set rs = CurrentDb.OpenRecordset(strQuery)
0018If Not rs.EOF Then
0019 rs.MoveFirst
0020 Functor_05 = "Yes"
0021Else
0022 Functor_05 = "No"
0023 Exit Function
0024End If
0025Do Until rs.EOF
0026 Category = rs.Fields(0) & ""
0027 Implementation_Period = rs.Fields(1)
0028 Development = rs.Fields(2) & ""
0029 If (Implementation_Period <> Implementation_Period_Saved) Or (Category <> Category_Saved) Then
0030 If Implementation_Period_Saved <> "ZZZZ" Then
0031 'Finalise Previous Implementation Period
0032 strImplementation_Period_Text = "|##|" & strImplementation_Period_Text & "|##|"
0033 strImplementation_Period_Text = "|1|<b>" & Implementation_Period_Saved & "</b>" & strImplementation_Period_Text
0034 End If
0035 'Ready for next Period
0036 If Category = Category_Saved Then
0037 strCategory_Text = strCategory_Text & strImplementation_Period_Text
0038 strImplementation_Period_Text = ""
0039 End If
0040 End If
0041 If Category <> Category_Saved Then
0042 If Category_Saved <> "ZZZZZ" Then
0043 'Finalise Previous Priority
0044 strCategory_Text = "|ii|" & strCategory_Text & strImplementation_Period_Text & "|ii|"
0045 strCategory_Text = "|.|<b>" & Category_Saved & "</b>" & strCategory_Text
0046 End If
0047 'Ready for next Period
0048 strNote_Text_Local = strNote_Text_Local & strCategory_Text
0049 strCategory_Text = ""
0050 Implementation_Period_Saved = "ZZZZ"
0051 strImplementation_Period_Text = ""
0052 End If
0053 strImplementation_Period_Text = strImplementation_Period_Text & "|.|" & Development
0054 'Move on ...
0055 Category_Saved = Category
0056 Implementation_Period_Saved = Implementation_Period
0057 rs.MoveNext
0058Loop
0059'Finish the list ...
0060strImplementation_Period_Text = "|##|" & strImplementation_Period_Text & "|##|"
0061strImplementation_Period_Text = "|1|<b>" & Implementation_Period_Saved & "</b>" & strImplementation_Period_Text
0062strCategory_Text = "|ii|" & strCategory_Text & strImplementation_Period_Text & "|ii|"
0063strCategory_Text = "|.|<b>" & Category_Saved & "</b>" & strCategory_Text
0064strNote_Text_Local = strNote_Text_Local & strCategory_Text
0065'Top and Tail
0066strNote_Text_Local = "<b><u>Completed Items By Category</u>:-</b> |..|" & strNote_Text_Local & "|..|"
0067'Tidy up
0068Set rs = Nothing
0069strNote_Text = strNote_Text_Local
0070End Function

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


Source Code of: Monthly_Report_Note1024_Update
Procedure Type: Public Sub
Module: Monthly Reporting
Lines of Code: 133
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Monthly_Report_Note1024_Update()
0002Dim strLine As String
0003Dim rsTableControl As Recordset
0004Dim rsTableControl2 As Recordset
0005Dim strQuery As String
0006Dim i As Long
0007Dim j As Integer
0008Dim iTaskCount As Integer
0009Dim iFirstTaskCol As Integer
0010Dim ifields As Integer
0011Dim Field_Width As Single
0012Dim Field_Width_Temp As Single
0013Dim iTableWidth As Single
0014Dim Alignment As String
0015Dim Field_Temp As String
0016Dim strTaskFN As String
0017Dim iNoteID As Integer
0018 Set rsTableControl2 = CurrentDb.OpenRecordset("Thesis_Progress_Dashboard_List")
0019rsTableControl2.MoveFirst
0020ifields = rsTableControl2.Fields.Count
0021iTaskCount = 0
0022For i = 0 To ifields - 1
0023 If InStr(rsTableControl2.Fields(i).Name, "Progress") > 0 Then
0024 If iTaskCount = 0 Then
0025 iFirstTaskCol = i
0026 End If
0027 iTaskCount = iTaskCount + 1
0028 End If
0029Next i
0030strTaskFN = "The definitions of the " & iTaskCount & " tasks are a follows:-"
0031 strTaskFN = strTaskFN & "|99||1|Determine which Notes that I have written are relevant to this Chapter."
0032strTaskFN = strTaskFN & "|1|Fill out any Note-place-holders with whatever's in my head!"
0033 strTaskFN = strTaskFN & "|1|Use the reading lists associated with these Notes to establish a limited reading list for the Chapter."
0034strTaskFN = strTaskFN & "|1|Review whatever I've written, in whatever format, on the items in the derived reading lists, and make necessary cosmetic changes in the process of evaluating the items."
0035strTaskFN = strTaskFN & "|1|Segregate this reading list into:- |..|"
0036strTaskFN = strTaskFN & "|.|Higher versus lower priority,"
0037strTaskFN = strTaskFN & "|.|Read versus unread,"
0038strTaskFN = strTaskFN & "|.|Annotated (by hand) versus unannotated"
0039strTaskFN = strTaskFN & "|.|Those with an Abstract or Note Write-up versus those without|..|"
0040strTaskFN = strTaskFN & "|1|Cull items that are unlikely to be addressed in the next two years and list them as specifically excluded. I may pick up on these at a later stage of the project, but in the short term the culling process will be essential for making across-the-board progress."
0041strTaskFN = strTaskFN & "|1|Determine why the residue are important and relevant - if they are - and briefly document the reasons."
0042 strTaskFN = strTaskFN & "|1|Migrate any Book or Paper Abstracts that I have written (as distinct from copied from elsewhere) to Write-Up Notes."
0043 strTaskFN = strTaskFN & "|1|If the Book or Paper is important enough, migrate any hand-written annotations to a Write-Up Note, and complete any important incomplete Write-Up Notes."
0044strTaskFN = strTaskFN & "|1|Write and maintain a Chapter Summary, motivating and summarising the Chapter. Use this to ensure I don't get side-tracked."
0045 strTaskFN = strTaskFN & "|1|Incorporate the key points of Write-Up Notes into the Topic Notes."
0046 strTaskFN = strTaskFN & "|1|Incorporate the highest level thoughts from the Topic Notes into the Main Text of the Chapter. |99|"
0047strLine = "<p>Below is a table++FN|..||.|<b>Note to myself</b>: this table is +TThesis_Progress_DashboardT+, maintainable via +QThesis_Progress_Dashboard_ListQ+ |.|Don't try to update Note 1024 directly as it'll get overwritten. |.|Other narrative is in the code +CMonthly_Report_Note1024_UpdateC+. |..| ++ showing the indicative progress on my Thesis++733++, broken down by Chapter. More detail is given in footnotes. For a definition of the Tasks, follow this Link++FN" & strTaskFN & "++. </p>"
0048Field_Width = 100 / (iTaskCount + 4.5)
0049iTableWidth = (iTaskCount + 4.5) * 85
0050If Not rsTableControl2.EOF Then
0051 rsTableControl2.MoveFirst
0052 strLine = strLine & "<center><TABLE class = ""Code"" WIDTH=" & iTableWidth & ">"
0053End If
0054'Header Row
0055strLine = strLine & "<TR>"
0056j = 1
0057Do While j < iFirstTaskCol + iTaskCount
0058 Field_Width_Temp = Field_Width
0059 Alignment = "BridgeCenter"
0060 Select Case j
0061 Case 1
0062 Field_Width_Temp = Field_Width * 4.5
0063 Alignment = "BridgeLeft"
0064 Field_Temp = "Chapter"
0065 Case Is > 1
0066 Field_Temp = "Task " & Right(rsTableControl2.Fields(j).Name, 2)
0067 End Select
0068 strLine = strLine & "<TH WIDTH=""" & Round(Field_Width_Temp, 1) & "%"" Class = """ & Alignment & """>" & Field_Temp & "</TH>"
0069 j = j + 1
0070Loop
0071strLine = strLine & "</TR>"
0072'Output the rows
0073rsTableControl2.MoveFirst
0074Do While Not rsTableControl2.EOF
0075 i = i + 1
0076 strLine = strLine & "<TR>"
0077 j = 0
0078 Do While j < iFirstTaskCol + iTaskCount
0079 Field_Width_Temp = Field_Width
0080 Alignment = "BridgeCenter"
0081 Select Case j
0082 Case 0
0083 iNoteID = rsTableControl2.Fields(j)
0084 Case 1
0085 Field_Width_Temp = Field_Width * 4.5
0086 Alignment = "BridgeLeft"
0087 Field_Temp = Left(rsTableControl2.Fields(j), Len("Chapter 10")) & "++" & iNoteID & "++" & Mid(rsTableControl2.Fields(j), Len("Chapter 10") + 1, Len(rsTableControl2.Fields(j)))
0088 Case Is > 1
0089 If rsTableControl2.Fields(j) & "" = "" Then
0090 Field_Temp = "&nbsp;"
0091 Else
0092 Field_Temp = rsTableControl2.Fields(j)
0093 If rsTableControl2.Fields(j + iTaskCount) & "" = "" Then
0094 Else
0095 Field_Temp = Field_Temp & "++FN" & rsTableControl2.Fields(j + iTaskCount) & "++"
0096 End If
0097 End If
0098 End Select
0099 If j > 0 Then
0100 strLine = strLine & "<TD WIDTH=""" & Round(Field_Width_Temp, 1) & "%"" Class = """ & Alignment & """>" & Field_Temp & "</TD>"
0101 End If
0102 j = j + 1
0103 Loop
0104 strLine = strLine & "</TR>"
0105 rsTableControl2.MoveNext
0106Loop
0107'Footer
0108strLine = strLine & "</TABLE></CENTER>"
0109'Read Note 1024 for update
0110 strQuery = "SELECT Notes.* FROM Notes WHERE Notes.ID = 1024;"
0111Set rsTableControl = CurrentDb.OpenRecordset(strQuery)
0112rsTableControl.MoveFirst
0113rsTableControl.Edit
0114'Update Note 1024
0115'Note Text
0116rsTableControl.Fields(3) = strLine
0117'Note Title
0118strLine = "Status: Thesis Dashboard (" & StrTitle_Year & ": " & StrTitle_Month & ")"
0119rsTableControl.Fields(1) = strLine
0120'Set Note Status
0121rsTableControl.Fields(10) = "Temp"
0122rsTableControl.Update
0123'Output the Note regeneration request
0124 DoCmd.RunSQL ("DELETE Notes_To_Regen.* FROM Notes_To_Regen;")
0125 Set rsTableControl = CurrentDb.OpenRecordset("SELECT Notes_To_Regen.* FROM Notes_To_Regen;")
0126rsTableControl.AddNew
0127rsTableControl.Fields(0) = 1024
0128rsTableControl.Update
0129Archive_Notes_Now = "No"
0130Regenerate_the_Links = "No"
0131Regen_Notes_Only = "Yes"
0132 CreateNotesWebPages
0133End Sub

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


Source Code of: PapersToNotes_Prelims
Procedure Type: Public Sub
Module: Testing
Lines of Code: 10

Line-No. / Ref.Code Line
0001Public Sub PapersToNotes_Prelims()
0002Dim strQuery As String
0003 strQuery = "DELETE * FROM Cross_Reference_Prelims;"
0004DoCmd.RunSQL (strQuery)
0005 strQuery = "PapersToNotes_Prelims_GEN"
0006DoCmd.OpenQuery (strQuery)
0007'Delete rows associated with Note 874 (Auto-Xref Test Note)
0008 strQuery = "DELETE * FROM Cross_Reference_Prelims WHERE Calling_ID = 874 AND Calling_Type = ""N"";"
0009DoCmd.RunSQL (strQuery)
0010End Sub

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


Source Code of: Pianola_Check
Procedure Type: Public Sub
Module: Testing
Lines of Code: 151
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Pianola_Check()
0002Dim ie As InternetExplorer
0003Dim html
0004Dim i As Long
0005Dim j As Long
0006Dim k As Long
0007Dim Requested_URL
0008Dim Returned_URL
0009Dim start As Date
0010Dim RunTime As Single
0011Dim Running_Hours As Single
0012Dim Issue As String
0013Dim Defunct As Boolean
0014Dim Update_Time As Double
0015Dim Recent_Check As Date
0016Dim Recent_Check_OK As Boolean
0017Dim Last_Bounce As Date
0018Dim Given_Up As Boolean
0019Dim Uncheckable As Boolean
0020Dim strDocument As String
0021Dim Pianola_ID As Long
0022Dim Max_Pianola As Long
0023Dim Pianola_Root As String
0024Dim strDate As String
0025Max_Pianola = 100
0026Pianola_ID = 2
0027Pianola_Root = "https://app.pianola.net/Results/Session"
0028'Fix the parameters below ...
0029Stop
0030Recent_Check = Now() - 10 'Parameter - Check gap in days
0031RunTime = 5 'Parameter - run time in hours
0032'Open Internet Explorer in memory, and go to website
0033Set ie = New InternetExplorer
0034ie.Visible = False
0035start = Now()
0036Last_Bounce = start
0037Do While Pianola_ID < Max_Pianola
0038 'Bounce IE every 5 minutes
0039 If (Now() - Last_Bounce) * 24 * 60 > 5 Then
0040 ie.Quit
0041 Set ie = Nothing
0042 Set ie = New InternetExplorer
0043 ie.Visible = False
0044 Last_Bounce = Now()
0045 Debug.Print Now() & " - "; "IE Bounced at " & Last_Bounce
0046 End If
0047 Uncheckable = False
0048 Update_Time = Now()
0049 Given_Up = False
0050 Recent_Check_OK = True
0051 If Recent_Check_OK = True Then
0052 Requested_URL = Pianola_Root & Pianola_ID
0053 Defunct = False
0054 Issue = ""
0055 On Error GoTo Err_Fix
0056Resume_Here:
0057 ie.Navigate Requested_URL
0058 Update_Time = Now()
0059 'Wait until IE is done loading page
0060 i = 1
0061 Do While ie.ReadyState <> READYSTATE_COMPLETE
0062 DoEvents
0063 i = i + 1
0064 If i > 3000 Then
0065 Given_Up = True
0066 GoTo Give_Up
0067 End If
0068 Loop
0069Give_Up:
0070 If Given_Up = False Then
0071 Returned_URL = ie.LocationURL
0072 strDocument = ie.Document
0073 If strDocument = "[object HTMLDocument]" Then
0074 strDocument = ie.Document.DocumentElement.innerHtml
0075 Else
0076 strDocument = ie.Document.DocumentElement.innerHtml
0077 End If
0078 If Requested_URL <> Returned_URL Then
0079 If Replace(Returned_URL, "https", "http") = Requested_URL Then
0080 Debug.Print Now() & " - "; "URL Secured: "; Returned_URL
0081 Issue = "URL Secured"
0082 Else
0083 If (Requested_URL & "/" = Returned_URL) Or (Requested_URL = Returned_URL & "/") Then
0084 Debug.Print Now() & " - "; "URL with trailing slash: "; Returned_URL
0085 Issue = "URL with trailing slash"
0086 Else
0087 If Left(Returned_URL, Len("http://www.webaddresshelp.bt.com")) = "http://www.webaddresshelp.bt.com" Then
0088 Debug.Print Now() & " - "; "URL Not found"
0089 Issue = "URL Not found"
0090 Defunct = True
0091 Else
0092 If Left(Returned_URL, Len("http://web.demo.barefruit.co.uk/")) = "http://web.demo.barefruit.co.uk/" Then
0093 Debug.Print Now() & " - "; "Website reports Document Not Found"
0094 Issue = "Document Not Found"
0095 Else
0096 Debug.Print Now() & " - "; "URL Differs: "; Returned_URL
0097 Issue = "URL Differs"
0098 End If
0099 End If
0100 End If
0101 End If
0102 End If
0103 i = InStr(strDocument, "<title>")
0104 If i > 0 Then
0105 j = InStr(i, strDocument, "</title>")
0106 If j > 0 Then
0107 k = InStr(i, strDocument, ",")
0108 End If
0109 If k > 0 And k < j Then
0110 strDate = Trim(Mid(strDocument, k + 1, j - k - 1))
0111 Debug.Print Now() & " - "; Pianola_ID, strDate
0112 End If
0113 End If
0114 i = InStr(strDocument, "<a href=""/Results/PublicView/")
0115 k = Len("<a href=""/Results/PublicView/")
0116 If i > 0 Then
0117 j = InStr(i + k, strDocument, """>")
0118 If j > 0 Then
0119 strDate = Trim(Mid(strDocument, i + k, j - i - k))
0120 Debug.Print Now() & " - "; Pianola_ID, strDate
0121 End If
0122 End If
0123 End If
0124 End If
0125 If Given_Up = True Then
0126 'Flag those with file-types that can't be checked
0127 End If
0128 Running_Hours = (Now() - start) * 24
0129 If Running_Hours > RunTime Then
0130 Stop
0131 start = Now()
0132 End If
0133 Pianola_ID = Pianola_ID + 1
0134Loop
0135ie.Quit
0136Set ie = Nothing
0137Debug.Print Now() & " - "; "Job complete at " & Now()
0138MsgBox "Webrefs Checker Completed at " & Now()
0139Exit Sub
0140Err_Fix:
0141Debug.Print Now() & " - "; Err.Description
0142DoEvents
0143Err.Clear
0144ie.Quit
0145Set ie = Nothing
0146Set ie = New InternetExplorer
0147ie.Visible = False
0148Last_Bounce = Now()
0149Debug.Print Now() & " - "; "IE Bounced at " & Last_Bounce
0150GoTo Resume_Here
0151End Sub

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


Source Code of: Prune_Raw_Links
Procedure Type: Public Function
Module: Spider
Lines of Code: 24
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Prune_Raw_Links(strDirectory, strFile)
0002Dim rsRawLinks As Recordset
0003Dim strQuery As String
0004Dim i As Integer
0005Dim strMessage As String
0006 strQuery = "SELECT Raw_Links.* FROM Raw_Links WHERE (((Raw_Links.Directory)=""" & strDirectory & """) AND ((Raw_Links.File_Name)=""" & strFile & """));"
0007Set rsRawLinks = CurrentDb.OpenRecordset(strQuery)
0008If Not rsRawLinks.EOF Then
0009 rsRawLinks.MoveFirst
0010 i = 0
0011 Do Until rsRawLinks.EOF
0012 rsRawLinks.Delete
0013 i = i + 1
0014 rsRawLinks.MoveNext
0015 Loop
0016 strMessage = i & " Raw_Links deleted."
0017Else
0018 strMessage = "No Raw_Links to delete."
0019End If
0020 OK = Check_Database_Size()
0021 strMessage = strMessage & " (Main Database size = " & Check_Database_Size & "Mb)"
0022Debug.Print Now() & " - Prune_Raw_Links: File = " & strDirectory & strFile & ". " & strMessage
0023Set rsRawLinks = Nothing
0024End Function

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


Source Code of: Remove_Hyperlinks
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 37
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Remove_Hyperlinks(Photo_Title)
0002Dim Hyperlink_Start As Integer
0003Dim Hyperlink_End As Integer
0004Dim Photo_Title_Local
0005Dim Hyperlink As String
0006Photo_Title_Local = Photo_Title
0007'Remove hard-codings ...
0008Hyperlink_Start = 1
0009Do While Hyperlink_Start > 0
0010 Hyperlink_Start = InStr(Hyperlink_Start, Photo_Title_Local, "<a href")
0011 If Hyperlink_Start > 0 Then
0012 Hyperlink_End = InStr(Hyperlink_Start, Photo_Title_Local, ">")
0013 Photo_Title_Local = Left(Photo_Title_Local, Hyperlink_Start - 1) & Mid(Photo_Title_Local, Hyperlink_End + 1)
0014 End If
0015Loop
0016Photo_Title_Local = Replace(Photo_Title_Local, "</a>", "")
0017'Remove Note-links
0018Hyperlink_Start = 1
0019Do While Hyperlink_Start > 0
0020 Hyperlink_Start = InStr(Hyperlink_Start, Photo_Title_Local, "++")
0021 If Hyperlink_Start > 0 Then
0022 Hyperlink_End = InStr(Hyperlink_Start + 1, Photo_Title_Local, "++")
0023 If Hyperlink_End > 0 Then
0024 Hyperlink = Mid(Photo_Title_Local, Hyperlink_Start, Hyperlink_End - Hyperlink_Start + 2)
0025 If Len(Hyperlink) < 20 Then
0026 Photo_Title_Local = Left(Photo_Title_Local, Hyperlink_Start - 1) & Mid(Photo_Title_Local, Hyperlink_Start + Len(Hyperlink))
0027 Else
0028 Hyperlink_Start = Hyperlink_Start + 20
0029 End If
0030 Else
0031 Hyperlink_Start = 0
0032 End If
0033 End If
0034Loop
0035'Return
0036Remove_Hyperlinks = Photo_Title_Local
0037End Function

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


Source Code of: TrimBranches
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 18

Line-No. / Ref.Code Line
0001Public Function TrimBranches(strText)
0002Dim x As Long
0003Dim Y As Long
0004Dim strText_Local As String
0005If Len(strText) = 0 Then
0006 TrimBranches = "Not Found"
0007 Exit Function
0008End If
0009strText_Local = strText
0010Y = 0
0011x = 1
0012Do Until x = Y
0013 x = Len(strText)
0014 strText_Local = Replace(strText_Local, "<BR><BR><BR>", "<BR><BR>")
0015 Y = Len(strText)
0016Loop
0017strText = strText_Local
0018End Function

Procedures Calling This Procedure (TrimBranches) Go To Top of This Page
Link to VBA Code Control Page


Source Code of: Zap_Cross_References
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 30
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Zap_Cross_References(Calling_Type, Calling_ID, Calling_Timestamp)
0002'This function does two things: (a) deletes the references associated with a calling object (b) saves these references in the zapper table so they can be compared with the replacement rows and appropriate action taken
0003Dim strQuery As String
0004Dim Calling_ID_Local As Integer
0005Dim rsAuthors As Recordset
0006'Zap the Zapper
0007 strQuery = "DELETE * FROM Cross_Reference_Zapper;"
0008DoCmd.RunSQL (strQuery)
0009'Find the Calling_ID for Authors
0010If Calling_Type = "A" Then
0011 strQuery = "SELECT Authors.Author_ID FROM Authors WHERE Authors.Author_Name=""" & Calling_ID & """;"
0012 Set rsAuthors = CurrentDb.OpenRecordset(strQuery)
0013 If Not rsAuthors.EOF Then
0014 Calling_ID_Local = rsAuthors.Fields(0)
0015 Else
0016 Calling_ID_Local = 0
0017 End If
0018 Set rsAuthors = Nothing
0019Else
0020 Calling_ID_Local = Calling_ID
0021End If
0022If Calling_ID_Local <> 0 Then
0023 'Populate the Zapper
0024 strQuery = "INSERT INTO Cross_Reference_Zapper SELECT Cross_Reference.* FROM Cross_Reference WHERE (((Cross_Reference.Calling_Type)=""" & Calling_Type & """) AND ((Cross_Reference.Calling_ID)=" & Calling_ID_Local & ") AND ((Cross_Reference.Calling_Timestamp)=" & Calling_Timestamp & "));"
0025 DoCmd.RunSQL (strQuery)
0026 'Do the Zapping
0027 strQuery = "DELETE Cross_Reference.* FROM Cross_Reference INNER JOIN [Cross_Reference_Zapper] ON Cross_Reference.ID = [Cross_Reference_Zapper].ID;"
0028 DoCmd.RunSQL (strQuery)
0029End If
0030End Function

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


© Theo Todman, June 2007 - Oct 2020. 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 Philosophy Page Return to Theo Todman's Home Page