Line-No. / Ref. Code Line
0001 Private Sub cmdAeon_Click()
0002 Dim strMessage As String
0003 strMessage = "Import Aeon_Files from WebRefs?"
0004 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0005 DoCmd.OpenQuery ("Aeon_New_Items_Add")
0006 End If
0007 strMessage = "Update Aeon_Files table?"
0008 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0009 DoCmd.OpenQuery ("Aeon_Prioritise")
0010 End If
0011 strMessage = "Search Aeon_Files table?"
0012 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0013 DoCmd.OpenQuery ("Aeon_Search")
0014 End If
0015 strMessage = "Select Aeon_Files table by ID?"
0016 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0017 DoCmd.OpenQuery ("Aeon_Lookup")
0018 End If
0019 strMessage = "Import Authors from Aeon_Files?"
0020 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0021 Aeon_Authors_Add
0022 End If
0023 strMessage = "Output the Aeon Note?"
0024 If MsgBox(strMessage, vbYesNo + vbDefaultButton2) = vbYes Then
0025 DoCmd.RunSQL ("DELETE * FROM Notes_To_Regen;")
0026 DoCmd.RunSQL ("INSERT INTO Notes_To_Regen ( Note_ID ) SELECT Notes.ID FROM Notes WHERE (((Notes.ID)=1292));") 'Regenerate the Aeon Note
0027 Archive_Notes_Now = "No"
0028 Regenerate_the_Links = "No"
0029 Regen_Notes_Only = "Yes"
0030 CreateNotesWebPages ("Yes")
0031 MsgBox (Now() & " - Aeon Note Output OK")
0032 Exit Sub
0033 End If
0034 End Sub
Line-No. / Ref. Code Line
0001 Public Sub Compressed_Photos_Copy()
0002 Dim fso As FileSystemObject
0003 Dim MainFolder
0004 Dim FileCollection
0005 Dim File
0006 Dim DirectoryName As String
0007 Dim Directory_To As String
0008 Dim File_Name As String
0009 Dim FileName_To As String
0010 Dim TransferName As String
0011 Dim iCopies As Integer
0012 Set 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\"
0015 DirectoryName = "C:\Theo's Files\Coxes Farm Repairs\General_Temp_Import\Compressed"
0016 Directory_To = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Repairs\"
0017 Set MainFolder = fso.GetFolder(DirectoryName)
0018 Set FileCollection = MainFolder.Files
0019 On Error Resume Next
0020 For 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
0031 Next File
0032 MsgBox Now() & "; Compressed_Photos_Copy Complete: Photos copied = " & iCopies & ". "
0033 End Sub
Line-No. / Ref. Code Line
0001 Public Function Functor_17(Note_ID, Note_Title, Note_Text, Option_ID)
0002 'Create an audio file list
0003 Dim rs As Recordset
0004 Dim strQuery As String
0005 Dim Note_Text_Local As String
0006 Dim str_Table_Header As String
0007 DoEvents
0008 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;"
0009 Set rs = CurrentDb.OpenRecordset(strQuery)
0010 If Not rs.EOF Then
0011 rs.MoveFirst
0012 Else
0013 Debug.Print Now() & " - "; "Functor_17: No Audio Files for this Note. Note ID = "; Note_ID; " Option = "; Option_ID
0014 Functor_17 = "No"
0015 Exit Function
0016 End If
0017 DoEvents
0018 'Create list
0019 str_Table_Header = " "
0020 Note_Text_Local = ""
0021 'Add rows to table
0022 Do Until rs.EOF
0023 Note_Text_Local = Note_Text_Local & str_Table_Header & "+ROboe_Practice_" & rs.Fields(8) & "R+" & " Your browser does not support the audio tag. "
0024 Note_Text_Local = Note_Text_Local & "" & rs.Fields(1) & " "
0025 If rs.Fields(3) & "" <> "" Then
0026 Note_Text_Local = Note_Text_Local & ". Grade: " & rs.Fields(3)
0027 End If
0028 If rs.Fields(4) > 1 Then
0029 Note_Text_Local = Note_Text_Local & " (Take " & rs.Fields(4) & ")"
0030 End If
0031 Note_Text_Local = Note_Text_Local & " (Recorded " & rs.Fields(5) & ")"
0032 If rs.Fields(6) & "" <> "" Then
0033 Note_Text_Local = Note_Text_Local & "Comments : " & rs.Fields(6)
0034 End If
0035 Note_Text_Local = Note_Text_Local & " "
0036 rs.MoveNext
0037 Note_Text_Local = Note_Text_Local & "
"
0038 Loop
0039 Note_Text = Note_Text_Local
0040 Functor_17 = "Yes"
0041 Set rs = Nothing
0042 End Function
Line-No. / Ref. Code Line
0001 Public Sub Photo_Copy2()
0002 Dim rst As Recordset
0003 Dim db As Database
0004 Dim TransferName As String
0005 Dim strQuery As String
0006 Dim Directory_To As String
0007 Dim FileName_To As String
0008 Dim FileName_From As String
0009 Dim iCopies As Integer
0010 Dim strPhotoQuery As String
0011 Dim Directory_From As String
0012 Dim Directory_Saved As String
0013 Dim File_Date As Date
0014 Dim strFile_Date As String
0015 Dim File_Suffix As String
0016 Dim i As Integer
0017 Dim Name_Suffix As String
0018 Dim fs As Object
0019 Static Error_Decision As String
0020 Dim Run_Case As Integer
0021 On 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
0026 Run_Case = 2
0027 iCopies = 0
0028 strPhotoQuery = "Coxes_Farm_Photos_Backup"
0029 Directory_Saved = ""
0030 i = 96 'Set to pre character "a"
0031 Set fs = CreateObject("Scripting.FileSystemObject")
0032 Set db = CurrentDb
0033 Directory_To = "C:\Theo's Files\Photos\Coxes Farm\Temp\"
0034 'Check the directories + step through for testing
0035 Stop
0036 strQuery = strPhotoQuery
0037 Set rst = db.OpenRecordset(strQuery)
0038 If Not rst.EOF Then
0039 rst.MoveFirst
0040 End If
0041 Do 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
0109 Loop
0110 Set fs = Nothing
0111 Set rst = Nothing
0112 MsgBox Now() & "; Photo Copy Complete: Photos copied = " & iCopies & ". "
0113 End Sub
Line-No. / Ref. Code Line
0001 Public Sub Photo_Preparation(strPhotoType)
0002 Dim rst As Recordset
0003 Dim db As Database
0004 Dim strQuery As String
0005 Dim File_Name As String
0006 Dim i As Integer
0007 Dim j As Integer
0008 Dim Link_Key As String
0009 Dim Link_Key_Saved As String
0010 Dim Picture_Detail As String
0011 Dim Picture_Detail_Saved As String
0012 Dim FileName As String
0013 Dim FileName_Saved As String
0014 Dim Photo_Popup_Title As String
0015 Dim Photo_Source As String
0016 Dim File_Timestamp As Date
0017 Set db = CurrentDb
0018 strQuery = "SELECT Photos_Raw.* FROM Photos_Raw WHERE Photos_Raw.Photo_Type=""" & strPhotoType & """;"
0019 Set rst = db.OpenRecordset(strQuery)
0020 If Not rst.EOF Then
0021 rst.MoveFirst
0022 End If
0023 Do 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
0069 Loop
0070 Set rst = Nothing
0071 Part2:
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;"
0073 Set rst = db.OpenRecordset(strQuery)
0074 If 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
0084 End If
0085 Do 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
0118 Loop
0119 Set rst = Nothing
0120 Part3:
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")
0125 If Not rst.EOF Then
0126 DoCmd.OpenQuery ("Photos_Raw_MultiType_List")
0127 Stop
0128 End If
0129 Set 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")
0134 If 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
0142 End If
0143 Set 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")
0148 If Not rst.EOF Then
0149 DoCmd.OpenQuery ("Photos_Raw_Excluded")
0150 Stop
0151 End If
0152 Set rst = Nothing
0153 MsgBox "Photo Preparation Complete"
0154 End Sub