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 42 (8 items)

cmdDisplayArchivedNote_ClickFunctor_02Functor_03Functor_04
Functor_10WebEncodeFull_Link_Sections_FixReformat_Paper_Abstract

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

Go to top of page



Source Code of: cmdDisplayArchivedNote_Click
Procedure Type: Private Sub
Module: Form_Notes_Archive_Regen
Lines of Code: 30
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdDisplayArchivedNote_Click()
0002Dim Note_ID As Integer
0003Dim Note_Timestamp As Long
0004Dim ID_Start As Integer
0005Dim rs As Recordset
0006ID_Start = 0
0007 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0008 Set rs = CurrentDb.OpenRecordset("SELECT * FROM Notes_To_Regen;")
0009If [Forms]![Notes_Archive_Regen]![Combo1] & "" = "" Then
0010 MsgBox ("Enter a Note ID")
0011Else
0012 Note_ID = [Forms]![Notes_Archive_Regen]![Combo1]
0013 If [Forms]![Notes_Archive_Regen]![Combo3] & "" = "" Then
0014 'List all the archived Notes for Note
0015 rs.AddNew
0016 rs.Fields(0) = Note_ID
0017 rs.Update
0018 DoCmd.OpenQuery ("Notes_Archive_List_ID")
0019 Else
0020 'List a particular Archived Note
0021 Note_Timestamp = [Forms]![Notes_Archive_Regen]![Combo3]
0022 rs.AddNew
0023 rs.Fields(0) = Note_ID
0024 rs.Fields(1) = Note_Timestamp
0025 rs.Update
0026 DoCmd.OpenQuery ("Notes_Archive_List_ID+Timestamp")
0027 End If
0028End If
0029Set rs = Nothing
0030End Sub

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


Source Code of: Full_Link_Sections_Fix
Procedure Type: Public Sub
Module: Spider
Lines of Code: 48
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Full_Link_Sections_Fix()
0002Dim rst As Recordset
0003Dim db As Database
0004Dim strQuery As String
0005Dim Section_Link As String
0006Dim Full_Link As String
0007Dim Start_Pos As Integer
0008Dim i As Long
0009Dim j As Long
0010Dim k As Long
0011Set db = CurrentDb
0012k = 0
0013 strQuery = "SELECT Raw_Links.* FROM Raw_Links WHERE (((InStr([Full_Link] & """",""#""))>0) AND ((Raw_Links.Section_Link) Is Null) AND ((Raw_Links.Full_Link) Is Not Null));"
0014Set rst = db.OpenRecordset(strQuery)
0015If Not rst.EOF Then
0016 rst.MoveLast
0017 i = rst.RecordCount
0018End If
0019If Not rst.EOF Then
0020 j = 1
0021 rst.MoveFirst
0022 Do While Not rst.EOF
0023 Full_Link = rst.Fields(3)
0024 Start_Pos = InStr(Full_Link, "#")
0025 If Start_Pos > 0 Then
0026 Section_Link = Mid(Full_Link, Start_Pos)
0027 Full_Link = Left(Full_Link, Start_Pos - 1)
0028 rst.Edit
0029 rst.Fields(3) = Full_Link
0030 rst.Fields(7) = Section_Link
0031 rst.Update
0032 End If
0033 If j > i / 3 Then
0034 j = 0
0035 Set rst = Nothing
0036 Compact_Repair ("C:\Theo's Files\Birkbeck\Web_Generator_Performance")
0037 Set rst = db.OpenRecordset(strQuery)
0038 End If
0039 If j = 0 Then
0040 rst.MoveFirst
0041 Else
0042 rst.MoveNext
0043 End If
0044 j = j + 1
0045 Loop
0046End If
0047Set rst = Nothing
0048End Sub

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


Source Code of: Functor_02
Procedure Type: Public Function
Module: Functors
Lines of Code: 81
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_02(strQuery, strNote_Text)
0002'Development Log report - Completed Items - Date Sequence
0003Dim rs As Recordset
0004Dim strNote_Text_Local
0005Dim Implementation_Period As String
0006Dim Own_Website As Boolean
0007Dim Category As String
0008Dim Development As String
0009Dim Implementation_Period_Saved As String
0010Dim Own_Website_Saved As Boolean
0011Dim Category_Saved As String
0012Dim strPeriod_Text As String
0013Dim Own_Website_First_Done As Boolean
0014Dim Own_Website_First As Boolean
0015strNote_Text_Local = ""
0016Implementation_Period_Saved = "99Q9"
0017strPeriod_Text = ""
0018Category_Saved = ""
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020If Not rs.EOF Then
0021 rs.MoveFirst
0022 Functor_02 = "Yes"
0023Else
0024 Functor_02 = "No"
0025 Exit Function
0026End If
0027Do Until rs.EOF
0028 Implementation_Period = rs.Fields(0) & ""
0029 Own_Website = rs.Fields(1)
0030 Category = rs.Fields(2) & ""
0031 Development = rs.Fields(3)
0032 If Implementation_Period <> Implementation_Period_Saved Then
0033 If Implementation_Period_Saved <> "99Q9" Then
0034 'Finalise Previous Period
0035 If Own_Website_First <> Own_Website_Saved Then
0036 strPeriod_Text = "|II||1|<b>Own Website</b>|ii|" & strPeriod_Text & "|##||ii||II|"
0037 Else
0038 strPeriod_Text = "|ii|" & strPeriod_Text & "|##||ii|"
0039 End If
0040 strPeriod_Text = "|.|<b>" & Implementation_Period_Saved & "</b>" & strPeriod_Text
0041 End If
0042 'Ready for next Period
0043 Own_Website_First_Done = False
0044 Own_Website_First = Own_Website
0045 strNote_Text_Local = strNote_Text_Local & strPeriod_Text
0046 strPeriod_Text = ""
0047 Category_Saved = ""
0048 End If
0049 If (Own_Website_First <> Own_Website) And (Own_Website_First_Done = False) Then
0050 strPeriod_Text = strPeriod_Text & "|##||ii||1|<b>Other Websites</b>|ii|"
0051 Own_Website_First_Done = True
0052 Category_Saved = ""
0053 End If
0054 If Category <> Category_Saved Then
0055 If Category_Saved <> "" Then
0056 strPeriod_Text = strPeriod_Text & "|##||1|<b>" & Category & "</b>:|##|"
0057 Else
0058 strPeriod_Text = strPeriod_Text & "|1|<b>" & Category & "</b>:|##|"
0059 End If
0060 End If
0061 strPeriod_Text = strPeriod_Text & "|.|" & Development
0062 'Move on ...
0063 Implementation_Period_Saved = Implementation_Period
0064 Own_Website_Saved = Own_Website
0065 Category_Saved = Category
0066 rs.MoveNext
0067Loop
0068'Finish the list ...
0069If Own_Website_First <> Own_Website_Saved Then
0070 strPeriod_Text = strPeriod_Text & "|##||ii||II|"
0071Else
0072 strPeriod_Text = "|ii|" & strPeriod_Text & "|##||ii|"
0073End If
0074strPeriod_Text = "|.|<b>" & Implementation_Period_Saved & "</b>" & strPeriod_Text
0075strNote_Text_Local = strNote_Text_Local & strPeriod_Text
0076'Top and Tail
0077strNote_Text_Local = "<b>[Items Completed In]++FN|..||.|There have been continual changes and bug-fixes that are not worth reporting. |.|A quarterly release - or the equivalent - of small changes is to be understood <em>passim</em>. |.|There were gaps in the development log that have been filled in from old reports. I've ignored developments for now-defunct sites. |.|However, for my own site I've erred in the direction of plenitude to remind me of what went on. I may prune the list in due course. |..|++:-</b> |..|" & strNote_Text_Local & "|..|"
0078'Tidy up
0079Set rs = Nothing
0080strNote_Text = strNote_Text_Local
0081End Function

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


Source Code of: Functor_03
Procedure Type: Public Function
Module: Functors
Lines of Code: 88
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_03(strQuery, strNote_Text)
0002'Development Log report - Outstanding Items by Priority
0003Dim rs As Recordset
0004Dim strNote_Text_Local
0005Dim Priority As Integer
0006Dim Category As String
0007Dim Status As String
0008Dim Development As String
0009Dim Priority_Saved As String
0010Dim strPriority_Text As String
0011Dim strPriority_Displayed As String
0012Dim Category_Saved As String
0013Dim strCategory_Text As String
0014strNote_Text_Local = ""
0015Priority_Saved = 0
0016strPriority_Text = ""
0017Category_Saved = "ZZZZ"
0018strCategory_Text = ""
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020If Not rs.EOF Then
0021 rs.MoveFirst
0022 Functor_03 = "Yes"
0023Else
0024 Functor_03 = "No"
0025 Exit Function
0026End If
0027Do Until rs.EOF
0028 Priority = rs.Fields(0)
0029 Category = rs.Fields(1) & ""
0030 Status = rs.Fields(2) & ""
0031 Development = rs.Fields(3) & ""
0032 If Category <> Category_Saved Or Priority <> Priority_Saved Then
0033 If Category_Saved <> "ZZZZ" Then
0034 'Finalise Previous Category
0035 strCategory_Text = "|##|" & strCategory_Text & "|##|"
0036 strCategory_Text = "|1|<b>" & Category_Saved & "</b>" & strCategory_Text
0037 End If
0038 'Ready for next Period
0039 strPriority_Text = strPriority_Text & strCategory_Text
0040 strCategory_Text = ""
0041 End If
0042 If Priority <> Priority_Saved Then
0043 If Priority_Saved <> 0 Then
0044 'Finalise Previous Priority
0045 strPriority_Text = "|ii|" & strPriority_Text & "|ii|"
0046 Select Case Priority_Saved
0047 Case 8
0048 strPriority_Displayed = "Work-arounds"
0049 Case 9
0050 strPriority_Displayed = "Cancelled Developments"
0051 Case Else
0052 strPriority_Displayed = "Priority: " & Priority_Saved
0053 End Select
0054 strPriority_Text = "|.|<b>" & strPriority_Displayed & "</b>" & strPriority_Text
0055 End If
0056 'Ready for next Period
0057 strNote_Text_Local = strNote_Text_Local & strPriority_Text
0058 strPriority_Text = ""
0059 strCategory_Text = ""
0060 Category_Saved = "ZZZZ"
0061 End If
0062 strCategory_Text = strCategory_Text & "|.|" & Development & IIf(Priority < 8, IIf(Status = "", "", IIf(Right(Trim(Development), 1) = "|", "", "<br>") & "<b>&rarr; " & Status & "</b>"), "")
0063 'Move on ...
0064 Priority_Saved = Priority
0065 Category_Saved = Category
0066 rs.MoveNext
0067Loop
0068'Finish the list ...
0069strCategory_Text = "|##|" & strCategory_Text & "|##|"
0070strCategory_Text = "|1|<b>" & Category_Saved & "</b>" & strCategory_Text
0071strPriority_Text = strPriority_Text & strCategory_Text
0072strPriority_Text = "|ii|" & strPriority_Text & "|ii|"
0073Select Case Priority_Saved
0074 Case 8
0075 strPriority_Displayed = "Work-arounds"
0076 Case 9
0077 strPriority_Displayed = "Cancelled Developments"
0078 Case Else
0079 strPriority_Displayed = "Priority: " & Priority_Saved
0080End Select
0081strPriority_Text = "|.|<b>" & strPriority_Displayed & "</b>" & strPriority_Text
0082strNote_Text_Local = strNote_Text_Local & strPriority_Text
0083'Top and Tail
0084strNote_Text_Local = "<b><u>Outstanding Items By Priority</u>:-</b> |..|" & strNote_Text_Local & "|..|"
0085'Tidy up
0086Set rs = Nothing
0087strNote_Text = strNote_Text_Local
0088End Function

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


Source Code of: Functor_04
Procedure Type: Public Function
Module: Functors
Lines of Code: 87
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_04(strQuery, strNote_Text)
0002'Website - Outstanding Developments - Outstanding Items by Category
0003Dim rs As Recordset
0004Dim strNote_Text_Local
0005Dim Priority As Integer
0006Dim Category As String
0007Dim Status As String
0008Dim Development As String
0009Dim Priority_Saved As String
0010Dim strPriority_Text As String
0011Dim strPriority_Displayed As String
0012Dim Category_Saved As String
0013Dim strCategory_Text As String
0014strNote_Text_Local = ""
0015Priority_Saved = 0
0016strPriority_Text = ""
0017Category_Saved = "ZZZZ"
0018strCategory_Text = ""
0019Set rs = CurrentDb.OpenRecordset(strQuery)
0020If Not rs.EOF Then
0021 rs.MoveFirst
0022 Functor_04 = "Yes"
0023Else
0024 Functor_04 = "No"
0025 Exit Function
0026End If
0027Do Until rs.EOF
0028 Category = rs.Fields(0) & ""
0029 Priority = rs.Fields(1)
0030 Status = rs.Fields(2) & ""
0031 Development = rs.Fields(3) & ""
0032 If Priority <> Priority_Saved Or Category <> Category_Saved Then
0033 If Priority_Saved <> 0 Then
0034 'Finalise Previous Priority
0035 strPriority_Text = "|##|" & strPriority_Text & "|##|"
0036 Select Case Priority_Saved
0037 Case 8
0038 strPriority_Displayed = "Work-arounds"
0039 Case 9
0040 strPriority_Displayed = "Cancelled Developments"
0041 Case Else
0042 strPriority_Displayed = "Priority: " & Priority_Saved
0043 End Select
0044 strPriority_Text = "|.|<b>" & strPriority_Displayed & "</b>" & strPriority_Text
0045 End If
0046 'Ready for next Period
0047 strCategory_Text = strCategory_Text & strPriority_Text
0048 strPriority_Text = ""
0049 End If
0050 If Category <> Category_Saved Then
0051 If Category_Saved <> "ZZZZ" Then
0052 'Finalise Previous Category
0053 strCategory_Text = "|..|" & strCategory_Text & "|..|"
0054 strCategory_Text = "|1|<b>" & Category_Saved & "</b>" & strCategory_Text
0055 End If
0056 'Ready for next Category
0057 strNote_Text_Local = strNote_Text_Local & strCategory_Text
0058 strCategory_Text = ""
0059 strPriority_Text = ""
0060 End If
0061 strPriority_Text = strPriority_Text & "|.|" & Development & IIf(Priority < 8, IIf(Status = "", "", IIf(Right(Trim(Development), 1) = "|", "", "<br>") & "<b>&rarr; " & Status & "</b>"), "")
0062 'Move on ...
0063 Priority_Saved = Priority
0064 Category_Saved = Category
0065 rs.MoveNext
0066Loop
0067'Finish the list ...
0068strPriority_Text = "|##|" & strPriority_Text & "|##|"
0069Select Case Priority_Saved
0070 Case 8
0071 strPriority_Displayed = "Work-arounds"
0072 Case 9
0073 strPriority_Displayed = "Cancelled Developments"
0074 Case Else
0075 strPriority_Displayed = "Priority: " & Priority_Saved
0076End Select
0077strPriority_Text = "|.|<b>" & strPriority_Displayed & "</b>" & strPriority_Text
0078strCategory_Text = strCategory_Text & strPriority_Text
0079strCategory_Text = "|..|" & strCategory_Text & "|..|"
0080strCategory_Text = "|1|<b>" & Category_Saved & "</b>" & strCategory_Text
0081strNote_Text_Local = strNote_Text_Local & strCategory_Text
0082'Top and Tail
0083strNote_Text_Local = "<b><u>Outstanding Items By Category</u>:-</b> |ii|" & strNote_Text_Local & "|ii|"
0084'Tidy up
0085Set rs = Nothing
0086strNote_Text = strNote_Text_Local
0087End Function

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


Source Code of: Functor_10
Procedure Type: Public Function
Module: Functors
Lines of Code: 59
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_10(Note_ID, Note_Title, Note_Text)
0002'Insert Plans for Near Future into Summary Status Report
0003Dim rs As Recordset
0004Dim rs2 As Recordset
0005Dim strQuery As String
0006Dim Note_Text_Local As String
0007Dim Note_Text_Sub_Report As String
0008Dim Project_ID As Integer
0009Dim Project_Name As String
0010Dim strPeriod As String
0011Dim strWeeklyPlan As String
0012 strQuery = "SELECT Projects.Priority, Projects.Project_Name, Projects.Status_Note FROM Projects WHERE (((Projects.Status_Note) > 0)) ORDER BY Projects.Priority;"
0013Set rs = CurrentDb.OpenRecordset(strQuery)
0014'Add the pick-list
0015rs.MoveFirst
0016Note_Text_Local = "|99|"
0017Note_Text_Local = Note_Text_Local & "|1|<a href=""#Off-Page_Link_Daily_Tasks"">Daily Tasks</a>"
0018Note_Text_Local = Note_Text_Local & "|1|<a href=""#Off-Page_Link_Top_10"">Top 10</a>"
0019Do While Not rs.EOF
0020 Project_ID = rs.Fields(2)
0021 Project_Name = rs.Fields(1)
0022 Note_Text_Local = Note_Text_Local & "|1|<a href=""#Off-Page_Link_Project_" & Project_ID & """>" & Project_Name & "</a>"
0023 rs.MoveNext
0024Loop
0025'Add the details
0026rs.MoveFirst
0027Note_Text_Local = Note_Text_Local & "|99|<hr><u>Detailed Lists</u>|99|"
0028Note_Text_Local = Note_Text_Local & "<a name=""Off-Page_Link_Daily_Tasks""></a>|1|<b>Daily Tasks</b> (<!-- FUNCTOR_ID=23, 25 --> <!-- FUNCTOR_END ID=23 -->) / day <!-- FUNCTOR_ID=22, 17 --> <!-- FUNCTOR_END ID=22 -->"
0029Note_Text_Local = Note_Text_Local & "<a name=""Off-Page_Link_Top_10""></a>|1|<b>Top 10 Items</b> <!-- FUNCTOR_ID=22, 16 --> <!-- FUNCTOR_END ID=22 -->"
0030Do While Not rs.EOF
0031 Project_ID = rs.Fields(2)
0032 Project_Name = rs.Fields(1)
0033 OK = Functor_09(Project_ID, Project_Name, Note_Text_Sub_Report)
0034 'Find the planned hours ...
0035 strPeriod = Year(Now()) & "-" & Right(100 + Month(Now()), 2)
0036 strQuery = "SELECT Project_Plans.Project, Project_Plans.Period, Project_Plans.Weekly_Hours FROM Project_Plans WHERE (((Project_Plans.Project)=""" & Project_Name & """) AND ((Project_Plans.Period)=""" & strPeriod & """));"
0037 Set rs2 = CurrentDb.OpenRecordset(strQuery)
0038 If rs2.EOF Then
0039 strWeeklyPlan = ""
0040 Else
0041 rs2.MoveFirst
0042 strWeeklyPlan = rs2.Fields(2)
0043 If strWeeklyPlan = 1 Then
0044 strWeeklyPlan = strWeeklyPlan & " hour"
0045 Else
0046 strWeeklyPlan = strWeeklyPlan & " hours"
0047 End If
0048 strWeeklyPlan = " (" & strWeeklyPlan & " per week)"
0049 End If
0050 Set rs2 = Nothing
0051 Note_Text_Local = Note_Text_Local & "<a name=""Off-Page_Link_Project_" & Project_ID & """></a>" & "|1|<B>[" & Project_Name & "]++" & Project_ID & "++</B>" & strWeeklyPlan & Note_Text_Sub_Report
0052 rs.MoveNext
0053Loop
0054'Finish Off
0055Note_Text_Local = Note_Text_Local & "|99|"
0056Note_Text = Note_Text_Local
0057Set rs = Nothing
0058Functor_10 = "Yes"
0059End Function

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


Source Code of: Reformat_Paper_Abstract
Procedure Type: Public Sub
Module: Testing
Lines of Code: 36
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Reformat_Paper_Abstract()
0002Dim rsObject As Recordset
0003Dim strQuery As String
0004Dim strRecord As String
0005Dim iUpdates As Long
0006Dim Duration As Single
0007Dim RunStartTime As Date
0008iUpdates = 0
0009RunStartTime = Now()
0010 strQuery = "SELECT Papers.Abstract FROM Papers WHERE (((Papers.Abstract) Like ""*This pseudo-Paper is intended as the mechanism to record time spent on the Note*"") AND ((Papers.Abstract) Not Like ""*|..|*""));"
0011Set rsObject = CurrentDb.OpenRecordset(strQuery)
0012If rsObject.EOF Then
0013 MsgBox ("No translations to do!")
0014 End
0015Else
0016 rsObject.MoveFirst
0017End If
0018Do Until rsObject.EOF
0019 strRecord = rsObject.Fields(0)
0020 strRecord = Replace(strRecord, "+N", "|.|+N")
0021 strRecord = "|..||.|" & strRecord & "|.|For the actual time recorded, click on ""Paper Summary"" above. |..|"
0022 Debug.Print Now() & " - "; strRecord
0023 rsObject.Edit
0024 rsObject.Fields(0) = strRecord
0025 rsObject.Update
0026 iUpdates = iUpdates + 1
0027 rsObject.MoveNext
0028Loop
0029Duration = Round((Now() - RunStartTime) * 24 * 60, 1)
0030If Duration < 1 Then
0031 Duration = Round((Now() - RunStartTime) * 24 * 60 * 60)
0032 MsgBox "Paper Abstracts Translated in " & Duration & " seconds. " & iUpdates & " changes made.", vbOKOnly, "Translate WebRefs"
0033Else
0034 MsgBox "Paper Abstracts Translated in " & Duration & " minutes. " & iUpdates & " changes made.", vbOKOnly, "Translate WebRefs"
0035End If
0036End Sub

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


Source Code of: WebEncode
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 163
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function WebEncode(strLineIn)
0002' This is a new routine to convert hard-coded external hyperlinks into my +WW+ format:
0003' These are added to WebRefs_Table if not already there
0004' The function returns the line passed updated with the +WW+s (the parameter is unchanged)
0005Dim z As Long
0006Dim zz As Long
0007Dim Y As Long
0008 Dim yy As Long
0009Dim i As Long
0010Dim j As Long
0011Dim strHTTP As String
0012Dim strLine As String
0013Dim FindChar As String
0014Dim strWebref1 As String
0015Dim Special_Search As String
0016Dim rsWebRefs As Recordset
0017strLine = strLineIn
0018z = 1
0019Do While z > 0
0020 'Find the next Weblink-start
0021 Y = InStr(z, strLine, "http")
0022 yy = InStr(z, strLine, "www")
0023 If yy > 0 Then
0024 If Mid(strLine, yy - 1, 1) = "/" Then 'Fudge for URLs with "/www" embedded in them (also applies to http://www, of course, but then http is prior to www
0025 yy = 0
0026 End If
0027 End If
0028 If Y + yy > 0 Then 'There is a link ...
0029 'Give preceedence to the earlier found link ..
0030 If Y = 0 Then 'So, it was www
0031 Y = yy
0032 strHTTP = "http://" 'Need to prefix http
0033 Else
0034 If yy = 0 Then
0035 strHTTP = "" 'It was http, so don't need to prefix http
0036 Else
0037 If yy < Y Then 'So, it was www
0038 Y = yy
0039 strHTTP = "http://" 'Need to prefix http
0040 Else
0041 strHTTP = "" 'It was http, so don't need to prefix http
0042 End If
0043 End If
0044 End If
0045 If InStr(Mid(strLine, IIf(Y > 10, Y - 10, 1), 10), "HREF") > 0 Then 'Fudge in case Weblink is at the start of the text!
0046 'Already had manually-encoded Web Ref, so ignore ...
0047 strWebref1 = "DummyDummy"
0048 Else
0049 'Now check for the "special" prefix ... "WRx" where x is the delimeter
0050 Special_Search = "No"
0051 If Y > 2 Then
0052 'Check for embedded search-character
0053 If Mid(strLine, Y - 3, 2) = "WR" Then
0054 Special_Search = "Yes"
0055 Else
0056 Special_Search = "No"
0057 End If
0058 End If
0059 If Special_Search = "Yes" Then
0060 FindChar = Mid(strLine, Y - 1, 1)
0061 strLine = Left(strLine, Y - 4) & Mid(strLine, Y)
0062 Y = Y - 3
0063 'The start has been found ... now find the end ...
0064 z = InStr(Y, strLine, FindChar) 'Assumes we've been careful!
0065 Else
0066 'The start has been found ... now find the end ...
0067 'Check for an open-ended list of delimiters that CANNOT themselves be part of a Weblink - if the function fails, look to add to these! ************
0068 z = InStr(Y, strLine, " ")
0069 zz = InStr(Y, strLine, Chr(9))
0070 If z = 0 Or (zz > 0 And z > zz) Then
0071 z = zz
0072 End If
0073 zz = InStr(Y, strLine, Chr(10))
0074 If z = 0 Or (zz > 0 And z > zz) Then
0075 z = zz
0076 End If
0077 zz = InStr(Y, strLine, Chr(13))
0078 If z = 0 Or (zz > 0 And z > zz) Then
0079 z = zz
0080 End If
0081 zz = InStr(Y, strLine, "<")
0082 If z = 0 Or (zz > 0 And z > zz) Then
0083 z = zz
0084 End If
0085 zz = InStr(Y, strLine, ")") 'Actually, this can be, and there's a corrective fudge later on ...
0086 If z = 0 Or (zz > 0 And z > zz) Then
0087 If zz > 0 Then
0088 strWebref1 = Mid(strLine, Y, zz - Y)
0089 If InStr(strWebref1, "(") = 0 Then 'The fudge: ")" isn't the terminator if there was a preceeding "(".
0090 z = zz
0091 End If
0092 End If
0093 End If
0094 zz = InStr(Y, strLine, "|")
0095 If z = 0 Or (zz > 0 And z > zz) Then
0096 z = zz
0097 End If
0098 zz = InStr(Y, strLine, ";")
0099 If z = 0 Or (zz > 0 And z > zz) Then
0100 z = zz
0101 End If
0102 zz = InStr(Y, strLine, ", ") 'Note the space! Commas are allowed within URLs
0103 If z = 0 Or (zz > 0 And z > zz) Then
0104 z = zz
0105 End If
0106 End If
0107 If z = 0 Then 'Assume the Weblink exhausts strLine
0108 z = Len(strLine) + 1
0109 End If
0110 ' Open-ended list of possible terminators that CAN be part of a Weblink - if the function fails, look to add to these! ************
0111 ' Basically assume that these will be followed by a universal delimeter, and can therefore be taken to be the real delimeter ...
0112 strWebref1 = Mid(strLine, Y, z - Y)
0113 zz = 0
0114 If Mid(strLine, z - 1, 1) = ":" Then
0115 zz = 1
0116 End If
0117 If Mid(strLine, z - 1, 1) = ")" Then
0118 i = Find_Count(strWebref1, ")")
0119 j = Find_Count(strWebref1, "(")
0120 If i <> j Then 'Ignore matching brackets
0121 zz = 1
0122 End If
0123 End If
0124 If Mid(strLine, z - 1, 1) = "." Then
0125 'Need to watch out for "Jr." ... and maybe others, which I'll add when they occur.
0126 If Mid(strLine, z - 3, 3) <> "Jr." Then
0127 zz = 1
0128 End If
0129 End If
0130 strWebref1 = strHTTP & Mid(strLine, Y, z - Y - zz)
0131 If strWebref1 & "" <> "" Then
0132 If Len(strWebref1) > 12 Then 'Check for HTTP as text!
0133 If InStr(strWebref1, """") > 0 Then 'Fudge ...
0134 Else
0135 Set rsWebRefs = CurrentDb.OpenRecordset("SELECT Webrefs_Table.* FROM Webrefs_Table WHERE (((Webrefs_Table.Webref)=""" & strWebref1 & """));")
0136 If rsWebRefs.EOF Then
0137 rsWebRefs.AddNew
0138 rsWebRefs.Fields(1) = Left(strWebref1, 255) '*****************
0139 rsWebRefs.Fields(2) = Now()
0140 rsWebRefs.Update
0141 End If
0142 Set rsWebRefs = Nothing
0143 Set rsWebRefs = CurrentDb.OpenRecordset("SELECT Webrefs_Table.* FROM Webrefs_Table WHERE (((Webrefs_Table.Webref)=""" & strWebref1 & """));")
0144 If Not rsWebRefs.EOF Then
0145 strWebref1 = "+W" & rsWebRefs.Fields(0) & "W+"
0146 If Special_Search = "Yes" Then
0147 strLine = Left(strLine, IIf(Y < 2, 0, (Y - 2))) & strWebref1 & Mid(strLine, z + 1 - zz)
0148 Else
0149 strLine = Left(strLine, Y - 1) & strWebref1 & Mid(strLine, z - zz)
0150 End If
0151 End If
0152 End If
0153 End If
0154 End If
0155 End If
0156 'Position ready for the next Weblink ...
0157 z = Y + Len(strWebref1)
0158 Else
0159 z = 0
0160 End If
0161Loop
0162WebEncode = strLine
0163End Function

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


© Theo Todman, June 2007 - May 2025. 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