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 27 (10 items)

cmdAeon_ClickCheck_Database_SizeFind_Report_PeriodFunctor_17
Images_AddCompressed_Photos_CopyCross_Reference_Changes_PrunePhoto_Copy2
Photo_PreparationWebpageGenDud_Abstracts_Books..

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

Go to top of page



Source Code of: Check_Database_Size
Procedure Type: Public Function
Module: Backups
Lines of Code: 20

Line-No. / Ref.Code Line
0001Public Function Check_Database_Size()
0002'This Function checks the size of the database, and if it's above a parameterised size, stops processing lest it blows the 2GB limit
0003Dim Check_File As String
0004Dim f As Object
0005Dim fso As FileSystemObject
0006Dim strProperty As String
0007Dim strMessage As String
0008Set fso = CreateObject("Scripting.FileSystemObject")
0009Check_File = CurrentDb.Name
0010Set f = fso.GetFile(Check_File)
0011strProperty = f.Size
0012strProperty = Int(strProperty / 1000 / 1024) + 1
0013If strProperty > Max_Database_Size Then
0014 strMessage = "Database size exceeds limit of " & Max_Database_Size & " Mb (at " & strProperty & " Mb). Compact and Repair before proceeding!"
0015 Debug.Print Now(); "Check_Database_Size: "; strMessage
0016 OK = MsgBox(strMessage)
0017 Stop
0018End If
0019Check_Database_Size = Val(strProperty)
0020End Function

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


Source Code of: cmdAeon_Click
Procedure Type: Private Sub
Module: Form_MainForm
Lines of Code: 38
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Private Sub cmdAeon_Click()
0002Dim strMessage As String
0003 strMessage = "Import Aeon_Files from WebRefs?"
0004If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0005 DoCmd.OpenQuery ("Aeon_New_Items_Add")
0006End If
0007strMessage = "Update Aeon Review Status?"
0008If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0009 DoCmd.OpenQuery ("Aeon_Review_Status_Update")
0010End If
0011 strMessage = "Update Aeon_Files table?"
0012If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0013 DoCmd.OpenQuery ("Aeon_Prioritise")
0014End If
0015 strMessage = "Search Aeon_Files table?"
0016If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0017 DoCmd.OpenQuery ("Aeon_Search")
0018End If
0019 strMessage = "Select Aeon_Files table by ID?"
0020If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0021 DoCmd.OpenQuery ("Aeon_Lookup")
0022End If
0023 strMessage = "Import Authors from Aeon_Files?"
0024If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0025 Aeon_Authors_Add
0026End If
0027strMessage = "Output the Aeon Note?"
0028If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0029 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0030 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=1292));") 'Regenerate the Aeon Note
0031 Archive_Notes_Now = "No"
0032 Regenerate_the_Links = "No"
0033 Regen_Notes_Only = "Yes"
0034 CreateNotesWebPages ("Yes")
0035 MsgBox (Now() & " - Aeon Note Output OK")
0036 Exit Sub
0037End If
0038End Sub

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


Source Code of: Compressed_Photos_Copy
Procedure Type: Public Sub
Module: Timelines
Lines of Code: 33
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Compressed_Photos_Copy()
0002Dim fso As FileSystemObject
0003Dim MainFolder
0004Dim FileCollection
0005Dim File
0006Dim DirectoryName As String
0007Dim Directory_To As String
0008Dim File_Name As String
0009Dim FileName_To As String
0010Dim TransferName As String
0011Dim iCopies As Integer
0012Set fso = CreateObject("Scripting.FileSystemObject")
0013'DirectoryName = "C:\Theo's Files\Coxes Farm Repairs\General_Temp_Import\Compressed"
0014'Directory_To = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Garden\"
0015DirectoryName = "C:\Theo's Files\Coxes Farm Repairs\General_Temp_Import\Compressed"
0016Directory_To = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Repairs\"
0017Set MainFolder = fso.GetFolder(DirectoryName)
0018Set FileCollection = MainFolder.Files
0019On Error Resume Next
0020For Each File In FileCollection
0021 File_Name = File.Name
0022 FileName_To = "Small_" & File_Name
0023 'FileName_To = Replace(File_Name, "CF_120131_", "")
0024 TransferName = Directory_To & FileName_To
0025 If Dir(TransferName) = "" Then 'If we already have a file in the transfer directory, then don't copy
0026 fso.CopyFile DirectoryName & "\" & File_Name, TransferName 'Copy to the transfer directory
0027 iCopies = iCopies + 1
0028 Else '
0029 Stop
0030 End If
0031Next File
0032MsgBox Now() & "; Compressed_Photos_Copy Complete: Photos copied = " & iCopies & ". "
0033End Sub

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


Source Code of: Cross_Reference_Changes_Prune
Procedure Type: Public Sub
Module: Testing
Lines of Code: 11

Line-No. / Ref.Code Line
0001Public Sub Cross_Reference_Changes_Prune()
0002Dim strQuery As String
0003 strQuery = "DELETE * FROM Cross_Reference_Zapper;"
0004DoCmd.RunSQL (strQuery)
0005 strQuery = "INSERT INTO Cross_Reference_Zapper ( ID, Calling_Type, Calling_ID, Calling_Timestamp, Called_Type, Called_ID, Called_Timestamp, Calling_NameRef, [Timestamp] ) SELECT Cross_Reference_Changes.ID, Cross_Reference_Changes.Calling_Type, Cross_Reference_Changes.Calling_ID, Cross_Reference_Changes.Calling_Timestamp, Cross_Reference_Changes.Called_Type, Cross_Reference_Changes.Called_ID, Cross_Reference_Changes.Called_Timestamp, Cross_Reference_Changes.Calling_NameRef, Cross_Reference_Changes.Timestamp FROM Cross_Reference_Changes, Website_Regen_Last_Run_Start WHERE (((Cross_Reference_Changes.Timestamp)<[Last_Run_Start] And (Cross_Reference_Changes.Timestamp)<(Now()-40)));"
0006DoCmd.RunSQL (strQuery)
0007 strQuery = "DELETE Cross_Reference_Changes.* FROM Cross_Reference_Changes INNER JOIN Cross_Reference_Zapper ON Cross_Reference_Changes.ID = Cross_Reference_Zapper.ID;"
0008DoCmd.RunSQL (strQuery)
0009 strQuery = "DELETE * FROM Cross_Reference_Zapper;"
0010DoCmd.RunSQL (strQuery)
0011End Sub

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


Source Code of: Find_Report_Period
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 32
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Find_Report_Period(Note_Title, strYear, strQuarter)
0002Dim i As Integer
0003Dim j As Integer
0004'Find the Report Year & Quarter from the Report Title
0005i = InStr(Note_Title, "(")
0006If i > 0 Then
0007 strYear = Mid(Note_Title, i + 1, 4)
0008Else
0009 strYear = "9999"
0010End If
0011j = InStr(Note_Title, "March")
0012If j > 0 Then
0013 strQuarter = "Q1"
0014Else
0015 j = InStr(Note_Title, "June")
0016 If j > 0 Then
0017 strQuarter = "Q2"
0018 Else
0019 j = InStr(Note_Title, "September")
0020 If j > 0 Then
0021 strQuarter = "Q3"
0022 Else
0023 j = InStr(Note_Title, "December")
0024 If j > 0 Then
0025 strQuarter = "Q4"
0026 Else
0027 strQuarter = "Q9"
0028 End If
0029 End If
0030 End If
0031End If
0032End Function

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


Source Code of: Functor_17
Procedure Type: Public Function
Module: Functors
Lines of Code: 52
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_17(Note_ID, Note_Title, Note_Text, Option_ID)
0002'Create an audio file list
0003Dim rs As Recordset
0004Dim strQuery As String
0005Dim Note_Text_Local As String
0006Dim str_Table_Header As String
0007DoEvents
0008Select Case Option_ID
0009 Case 1, 2
0010 strQuery = "SELECT Audio_Files.Sequence, Audio_Files.Piece_Name, Audio_Files.Audio_File, Audio_Files.Grade, Audio_Files.Take, Audio_Files.Creation_Date, Audio_Files.Comments, Audio_Files.Defunct, Audio_Files.ID FROM Audio_Files WHERE (((Audio_Files.Note_ID) = " & Note_ID & ") AND ((Audio_Files.Option) = " & Option_ID & ") AND Audio_Files.Defunct = FALSE) ORDER BY Audio_Files.Sequence, Audio_Files.Piece_Name, Audio_Files.Take;"
0011 Case 3
0012 strQuery = "SELECT Audio_Files.Sequence, Audio_Files.Piece_Name, Audio_Files.Audio_File, Audio_Files.Grade, Audio_Files.Take, Audio_Files.Creation_Date, Audio_Files.Comments, Audio_Files.Defunct, Audio_Files.ID FROM Audio_Files WHERE (((Audio_Files.Option) = " & Option_ID & ") AND Audio_Files.Defunct = FALSE) ORDER BY Audio_Files.Sequence, Audio_Files.Piece_Name, Audio_Files.Take;"
0013 Case Else
0014 Functor_17 = "No"
0015 Exit Function
0016End Select
0017Set rs = CurrentDb.OpenRecordset(strQuery)
0018If Not rs.EOF Then
0019 rs.MoveFirst
0020Else
0021 Debug.Print Now() & " - "; "Functor_17: No Audio Files for this Note. Note ID = "; Note_ID; " Option = "; Option_ID
0022 Functor_17 = "No"
0023 Exit Function
0024End If
0025DoEvents
0026'Create list
0027str_Table_Header = "<TABLE class = ""ReadingList"" WIDTH=1100>"
0028Note_Text_Local = ""
0029'Add rows to table
0030Do Until rs.EOF
0031 Note_Text_Local = Note_Text_Local & str_Table_Header & IIf(Option_ID < 3, "+ROboe_Practice_" & rs.Fields(8) & "R+", "") & "<TR><TD class = ""BridgeLeft"" width = 20%> <audio controls> <source src=""../../Audio/" & rs.Fields(2) & """ type=""audio/mpeg"">Your browser does not support the audio tag.</audio> </TD>"
0032 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft"" width = 80%><b>" & rs.Fields(1) & "</b>"
0033 If rs.Fields(3) & "" <> "" Then
0034 Note_Text_Local = Note_Text_Local & ". Grade: " & rs.Fields(3)
0035 End If
0036 If rs.Fields(4) > 1 Then
0037 Note_Text_Local = Note_Text_Local & " (Take " & rs.Fields(4) & ")"
0038 End If
0039 If Option_ID < 3 Then
0040 Note_Text_Local = Note_Text_Local & " (Recorded " & rs.Fields(5) & ")"
0041 End If
0042 If rs.Fields(6) & "" <> "" Then
0043 Note_Text_Local = Note_Text_Local & "<br><b>Comments</b>: " & rs.Fields(6)
0044 End If
0045 Note_Text_Local = Note_Text_Local & "</TD></TR>"
0046 rs.MoveNext
0047 Note_Text_Local = Note_Text_Local & "</TABLE>"
0048Loop
0049Note_Text = Note_Text_Local
0050Functor_17 = "Yes"
0051Set rs = Nothing
0052End Function

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


Source Code of: Images_Add
Procedure Type: Public Function
Module: Timelines
Lines of Code: 42
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Images_Add(strDirectory, strImageRef, SRC, Image)
0002Dim rs As Recordset
0003Dim strQuery As String
0004 strQuery = "SELECT Images.* FROM Images WHERE Images.File_Name = """ & strImageRef & """ ;"
0005Set rs = CurrentDb.OpenRecordset(strQuery)
0006On Error Resume Next
0007If rs.EOF Then
0008 rs.AddNew
0009 rs.Fields(1) = TheoWebsiteRoot & "\Photos\Notes\"
0010 If Len(strImageRef) > 255 Then
0011 rs.Fields(2) = "Dud: " & Left(strImageRef, 250)
0012 Else
0013 rs.Fields(2) = strImageRef
0014 End If
0015 rs.Fields(3) = Now()
0016 rs.Fields(4) = SRC
0017 rs.Fields(5) = Image
0018 rs.Update
0019 Set rs = Nothing
0020 Set rs = CurrentDb.OpenRecordset(strQuery)
0021 If rs.EOF Then
0022 Images_Add = 9999
0023 Else
0024 rs.MoveFirst
0025 End If
0026Else
0027 rs.MoveFirst
0028 rs.Edit
0029 rs.Fields(3) = Now()
0030 If SRC = True Then
0031 rs.Fields(4) = SRC
0032 End If
0033 If Image = True Then
0034 rs.Fields(5) = Image
0035 End If
0036 rs.Update
0037End If
0038 If Images_Add <> 9999 Then
0039 Images_Add = rs.Fields(0)
0040End If
0041Set rs = Nothing
0042End Function

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


Source Code of: Photo_Copy2
Procedure Type: Public Sub
Module: Timelines
Lines of Code: 113
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Photo_Copy2()
0002Dim rst As Recordset
0003Dim db As Database
0004Dim TransferName As String
0005Dim strQuery As String
0006Dim Directory_To As String
0007Dim FileName_To As String
0008Dim FileName_From As String
0009Dim iCopies As Integer
0010Dim strPhotoQuery As String
0011Dim Directory_From As String
0012Dim Directory_Saved As String
0013Dim File_Date As Date
0014Dim strFile_Date As String
0015Dim File_Suffix As String
0016Dim i As Integer
0017Dim Name_Suffix As String
0018Dim fs As Object
0019Static Error_Decision As String
0020Dim Run_Case As Integer
0021On Error Resume Next
0022'There are two runs
0023'... The first orders the photos from disk so they can be matched to those taken from the iPhone
0024'... The second prefixes the date to the front (with a CF_ prefix), with the original ID to the rear
0025'Run_Case = 1
0026Run_Case = 2
0027iCopies = 0
0028 strPhotoQuery = "Coxes_Farm_Photos_Backup"
0029Directory_Saved = ""
0030i = 96 'Set to pre character "a"
0031Set fs = CreateObject("Scripting.FileSystemObject")
0032Set db = CurrentDb
0033Directory_To = "C:\Theo's Files\Photos\Coxes Farm\Temp\"
0034'Check the directories + step through for testing
0035Stop
0036strQuery = strPhotoQuery
0037Set rst = db.OpenRecordset(strQuery)
0038If Not rst.EOF Then
0039 rst.MoveFirst
0040End If
0041Do Until rst.EOF
0042 'Transfer JPEG
0043 Directory_From = rst.Fields(0)
0044 If Directory_From <> Directory_Saved Then
0045 Directory_Saved = Directory_From
0046 i = i + 1
0047 Name_Suffix = Chr$(i)
0048 End If
0049 FileName_From = rst.Fields(1)
0050 File_Date = rst.Fields(3)
0051 If Year(File_Date) < 2011 Then
0052 File_Date = 0
0053 End If
0054 File_Suffix = rst.Fields(4)
0055 File_Suffix = Replace(File_Suffix, "\", "")
0056 File_Suffix = Replace(File_Suffix, "Coxes Farm_", "")
0057 File_Suffix = Replace(File_Suffix, "Coxes Farm", "")
0058 File_Suffix = Replace(File_Suffix, " ", "")
0059 File_Suffix = Replace(File_Suffix, "_", "")
0060 File_Suffix = Replace(File_Suffix, "(", "")
0061 File_Suffix = Replace(File_Suffix, ")", "")
0062 File_Suffix = Replace(File_Suffix, "+", "")
0063 strFile_Date = Left(File_Suffix, 8)
0064 If IsNumeric(strFile_Date) Then
0065 strFile_Date = Mid(strFile_Date, 3)
0066 File_Suffix = Mid(File_Suffix, 9)
0067 Else
0068 strFile_Date = Left(File_Suffix, 4)
0069 If IsNumeric(strFile_Date) Then
0070 strFile_Date = Mid(strFile_Date, 3) & "0601"
0071 File_Suffix = Mid(File_Suffix, 5)
0072 Else
0073 strFile_Date = ""
0074 End If
0075 End If
0076 If File_Date <> 0 Then
0077 If strFile_Date = "" Then
0078 strFile_Date = Mid(Year(File_Date), 3) & Right(100 + Month(File_Date), 2) & Right(100 + Day(File_Date), 2)
0079 End If
0080 End If
0081 Select Case Run_Case
0082 Case 1
0083 FileName_To = Left(FileName_From, InStr(FileName_From, ".jpg") - 1) & Name_Suffix
0084 If File_Suffix <> "" Then
0085 FileName_To = FileName_To & "_" & File_Suffix
0086 End If
0087 If strFile_Date <> "" Then
0088 FileName_To = FileName_To & "_" & strFile_Date
0089 End If
0090 Case 2
0091 FileName_To = "CF"
0092 If strFile_Date <> "" Then
0093 FileName_To = FileName_To & "_" & strFile_Date
0094 End If
0095 If File_Suffix <> "" Then
0096 FileName_To = FileName_To & "_" & File_Suffix
0097 End If
0098 FileName_To = FileName_To & "_" & Left(FileName_From, InStr(FileName_From, ".jpg") - 1) & Name_Suffix
0099 End Select
0100 FileName_To = FileName_To & ".jpg"
0101 TransferName = Directory_To & FileName_To
0102 If Dir(TransferName) = "" Then 'If we already have a file in the transfer directory, then don't copy
0103 fs.CopyFile Directory_From & FileName_From, TransferName 'Copy to the transfer directory
0104 iCopies = iCopies + 1
0105 Else
0106 Stop
0107 End If
0108 rst.MoveNext
0109Loop
0110Set fs = Nothing
0111Set rst = Nothing
0112MsgBox Now() & "; Photo Copy Complete: Photos copied = " & iCopies & ". "
0113End Sub

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


Source Code of: Photo_Preparation
Procedure Type: Public Sub
Module: Timelines
Lines of Code: 154
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Photo_Preparation(strPhotoType)
0002Dim rst As Recordset
0003Dim db As Database
0004Dim strQuery As String
0005Dim File_Name As String
0006Dim i As Integer
0007Dim j As Integer
0008Dim Link_Key As String
0009Dim Link_Key_Saved As String
0010Dim Picture_Detail As String
0011Dim Picture_Detail_Saved As String
0012Dim FileName As String
0013Dim FileName_Saved As String
0014Dim Photo_Popup_Title As String
0015Dim Photo_Source As String
0016Dim File_Timestamp As Date
0017Set db = CurrentDb
0018 strQuery = "SELECT Photos_Raw.* FROM Photos_Raw WHERE Photos_Raw.Photo_Type=""" & strPhotoType & """;"
0019Set rst = db.OpenRecordset(strQuery)
0020If Not rst.EOF Then
0021 rst.MoveFirst
0022End If
0023Do While Not rst.EOF
0024 'Determine Photo_Popup_Title
0025 File_Name = rst.Fields(1)
0026 Photo_Source = rst.Fields(3)
0027 If InStr(File_Name, "P101") > 0 Then
0028 Photo_Source = "Olympus Digital Camera"
0029 End If
0030 File_Timestamp = rst.Fields(4)
0031 If File_Timestamp = 0 Then
0032 File_Timestamp = rst.Fields(5)
0033 End If
0034 File_Name = rst.Fields(1)
0035 Photo_Popup_Title = rst.Fields(12) & ""
0036 If Photo_Popup_Title <> "" Then
0037 Photo_Popup_Title = " " & Photo_Popup_Title
0038 End If
0039 Photo_Popup_Title = File_Name & " (" & Photo_Source & " - " & File_Timestamp & ")" & Photo_Popup_Title
0040 Photo_Popup_Title = Photo_Popup_Title & " " & "Photo_ID = " & rst.Fields(13)
0041 'Find the Link Key, via last "_"
0042 i = 1
0043 j = 0
0044 Do Until i = 0
0045 i = InStr(i, File_Name, "_")
0046 If i > 0 Then
0047 j = i
0048 i = i + 1
0049 End If
0050 Loop
0051 i = InStr(File_Name, ".jpg")
0052 If i > 0 And j > 0 Then
0053 Link_Key = Mid(File_Name, j + 1, i - j - 1)
0054 Else
0055 If i > 0 Then
0056 Link_Key = Left(File_Name, i - 1)
0057 Else
0058 Link_Key = "None_" & rst.Fields(13)
0059 End If
0060 End If
0061 'Update the database
0062 rst.Edit
0063 rst.Fields(3) = Photo_Source
0064 rst.Fields(7) = Photo_Popup_Title
0065 rst.Fields(8) = Link_Key
0066 rst.Fields(10) = "" 'Clear matching photo (to allow for re-runs)
0067 rst.Update
0068 rst.MoveNext
0069Loop
0070Set rst = Nothing
0071Part2:
0072 strQuery = "SELECT Photos_Raw.Link_Key, Photos_Raw.Photo_Size, Photos_Raw.Photo_FileName, Photos_Raw.Photo_Detail, Photos_Raw.Matching_Photo_FileName, Photos_Raw.Photo_Type FROM Photos_Raw WHERE Photos_Raw.Photo_Type=""" & strPhotoType & """ AND Photos_Raw.[Exclude?]=FALSE ORDER BY Photos_Raw.Link_Key, Photos_Raw.Photo_Size DESC;"
0073Set rst = db.OpenRecordset(strQuery)
0074If Not rst.EOF Then
0075 rst.MoveFirst
0076 Link_Key_Saved = rst.Fields(0)
0077 FileName_Saved = rst.Fields(2)
0078 If rst.Fields(1) < 1000000 Then
0079 Picture_Detail_Saved = "Medium"
0080 Else
0081 Picture_Detail_Saved = "Full"
0082 End If
0083 rst.MoveNext
0084End If
0085Do While Not rst.EOF
0086 Link_Key = rst.Fields(0)
0087 If rst.Fields(1) < 1000000 Then
0088 Picture_Detail = "Medium"
0089 Else
0090 Picture_Detail = "Full"
0091 End If
0092 FileName = rst.Fields(2)
0093 If Link_Key = Link_Key_Saved Then
0094 rst.MovePrevious
0095 rst.Edit
0096 If Picture_Detail_Saved = "Medium" Then
0097 Picture_Detail_Saved = "Medium - Larger"
0098 End If
0099 rst.Fields(3) = Picture_Detail_Saved
0100 rst.Fields(4) = FileName
0101 rst.Update
0102 rst.MoveNext
0103 rst.Edit
0104 rst.Fields(3) = Picture_Detail
0105 rst.Fields(4) = FileName_Saved
0106 rst.Update
0107 Else
0108 rst.MovePrevious
0109 rst.Edit
0110 rst.Fields(3) = Picture_Detail_Saved
0111 rst.Update
0112 rst.MoveNext
0113 End If
0114 Link_Key_Saved = Link_Key
0115 Picture_Detail_Saved = Picture_Detail
0116 FileName_Saved = FileName
0117 rst.MoveNext
0118Loop
0119Set rst = Nothing
0120Part3:
0121'Check for inconsistent Photo-Types between different-sized images of the same photo
0122 DoCmd.RunSQL ("DELETE Photo_Raw_Excluded_Link_Keys.* FROM Photo_Raw_Excluded_Link_Keys;") 'Use a convenient table!
0123 DoCmd.OpenQuery ("Photo_Type_Goup_Mismatch_Gen")
0124 Set rst = CurrentDb.OpenRecordset("Photos_Raw_MultiType_List")
0125If Not rst.EOF Then
0126 DoCmd.OpenQuery ("Photos_Raw_MultiType_List")
0127 Stop
0128End If
0129Set rst = Nothing
0130'Check for inconsistent "exclusions"
0131 DoCmd.RunSQL ("DELETE Photo_Raw_Excluded_Link_Keys.* FROM Photo_Raw_Excluded_Link_Keys;")
0132 DoCmd.OpenQuery ("Photo_Raw_Excluded_Link_KeysQ") 'Add keys of excluded photos
0133 Set rst = CurrentDb.OpenRecordset("Photos_Raw_Excluded_Inconsistencies")
0134If rst.Fields.Count > 3 Then
0135 Set rst = Nothing
0136 Set rst = CurrentDb.OpenRecordset("Photos_Raw_Excluded_Errors")
0137 If Not rst.EOF Then
0138 DoCmd.OpenQuery ("Photos_Raw_Excluded")
0139 DoCmd.OpenQuery ("Photos_Raw_Excluded_Errors")
0140 Stop
0141 End If
0142End If
0143Set rst = Nothing
0144'Now check for where 3 photos for same ID, none of which is excluded
0145 DoCmd.RunSQL ("DELETE Photo_Raw_Excluded_Link_Keys.* FROM Photo_Raw_Excluded_Link_Keys;")
0146 DoCmd.OpenQuery ("Photo_Raw_Non_Excluded_Triplets") 'Add keys where more than two non-excluded photos have same key
0147 Set rst = CurrentDb.OpenRecordset("Photos_Raw_Excluded")
0148If Not rst.EOF Then
0149 DoCmd.OpenQuery ("Photos_Raw_Excluded")
0150 Stop
0151End If
0152Set rst = Nothing
0153MsgBox "Photo Preparation Complete"
0154End Sub

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


Source Code of: WebpageGenDud_Abstracts_Books
Procedure Type: Public Sub
Module: Webpage_Generators
Lines of Code: 28
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub WebpageGenDud_Abstracts_Books()
0002Dim rst As Recordset
0003 strControlTable = "Dud_Abstracts_Books"
0004 strOutputFileShort = "Dud_Abstracts_Books"
0005strOutputFolder = TheoWebsiteRoot & "\"
0006strOutputFile = strOutputFolder & strOutputFileShort
0007 strDataQuery = "Dud_Abstracts_Books"
0008strSplitTable = "No"
0009strControlBreakType = "Initial"
0010strControlBreakType2 = ""
0011Main_Header = "No"
0012Set rst = CurrentDb.OpenRecordset(strDataQuery)
0013If Not rst.EOF Then
0014 Set rst = Nothing
0015 If MsgBox("Did you intend there to be a dud book abstract? If not, reply ""No""", vbYesNo) = vbYes Then
0016 CreatePapersWebTable
0017 DoCmd.Close acQuery, "Dud_Abstracts_Books_Updateable"
0018 DoCmd.OpenQuery ("Dud_Abstracts_Books_Updateable")
0019 Else
0020 DoCmd.Close acQuery, "Dud_Abstracts_Books_Updateable"
0021 DoCmd.OpenQuery ("Dud_Abstracts_Books_Updateable")
0022 End If
0023Else
0024 Set rst = Nothing
0025 'Create "empty" page
0026 CreatePapersWebTable
0027End If
0028End Sub

Procedures Calling This Procedure (WebpageGenDud_Abstracts_Books) Procedures Called By This Procedure (WebpageGenDud_Abstracts_Books) Tables / Queries / Fragments Directly Used By This Procedure (WebpageGenDud_Abstracts_Books) 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