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 46 (5 items)

Cross_Reference_AddFunctor_15Functor_16GetProperty
Create_Timeline...

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

Go to top of page




Source Code of: Create_Timeline
Procedure Type: Public Sub
Module: Timelines
Lines of Code: 92
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Sub Create_Timeline(iOption)
0002Dim fso As FileSystemObject
0003Dim DirectoryName As String
0004Dim MainFolder
0005Dim FileCollection
0006Dim File
0007Dim File_Timestamp As Date
0008Dim File_Timestamp_Created As Date
0009Dim rst As Recordset
0010Dim db As Database
0011Dim File_Name As String
0012Dim File_Size As Long
0013Dim strDate As String
0014Dim strQuery As String
0015Dim strTimestamp_Manual As String
0016Dim Photo_Timestamp_Manual As Date
0017Dim Photo_Type As String
0018Dim Photo_Source As String
0019Dim iRecords_Added As Integer
0020iRecords_Added = 0
0021Set db = CurrentDb
0022Set fso = CreateObject("Scripting.FileSystemObject")
0023Select Case iOption
0024 Case 3
0025 DirectoryName = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Repairs"
0026 Photo_Type = "CoxesFarmRepairs"
0027 Photo_Source = "iPhone"
0028 Case 4
0029 DirectoryName = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_PreRepairs"
0030 Photo_Type = "CoxesFarmPreRepairs"
0031 Photo_Source = "iPhone"
0032 Case 5
0033 DirectoryName = "C:\Theo's Files\Coxes Farm Repairs\Photos_Import_Garden"
0034 Photo_Type = "CoxesFarmGardens"
0035 Photo_Source = "iPhone"
0036End Select
0037'Check the parameters
0038Stop
0039Set MainFolder = fso.GetFolder(DirectoryName)
0040Set FileCollection = MainFolder.Files
0041For Each File In FileCollection
0042 File_Name = File.Name
0043 'Analyse Name
0044 File_Name = Replace(File_Name, ".JPG", ".jpg")
0045 If Left(File_Name, 3) = "CF_" Then
0046 strTimestamp_Manual = Mid(File_Name, 4, 6)
0047 If IsNumeric(strTimestamp_Manual) Then
0048 strTimestamp_Manual = "" & Mid(strTimestamp_Manual, 5, 2) & " " & MonthName(Mid(strTimestamp_Manual, 3, 2)) & ", 20" & Left(strTimestamp_Manual, 2) & ""
0049 Photo_Timestamp_Manual = FormatDateTime(strTimestamp_Manual, vbLongDate)
0050 Else
0051 Photo_Timestamp_Manual = 0
0052 End If
0053 Else
0054 Photo_Timestamp_Manual = 0
0055 End If
0056 File_Timestamp_Created = File.DateCreated
0057 File_Size = File.Size
0058 strDate = GetProperty(DirectoryName & "\", File_Name, 12)
0059 strDate = Mid(strDate, 2)
0060 strDate = Left(strDate, 3) & Mid(strDate, 5)
0061 strDate = Left(strDate, 6) & Mid(strDate, 8)
0062 strDate = Left(strDate, 11) & Mid(strDate, 14)
0063 If IsDate(strDate) Then
0064 File_Timestamp = strDate
0065 Else
0066 File_Timestamp = 0
0067 End If
0068 'Check record not there ...
0069 strQuery = "SELECT Photos_Raw.* FROM Photos_Raw WHERE (((Photos_Raw.Photo_Type) = """ & Photo_Type & """ AND (Photos_Raw.Photo_FileName) = """ & File_Name & """));"
0070 Set rst = db.OpenRecordset(strQuery)
0071 If rst.EOF Then
0072 'Add a record
0073 If 1 = 2 Then 'Toggle for testing
0074 Debug.Print File_Name
0075 Else
0076 rst.AddNew
0077 rst.Fields(0) = Photo_Type
0078 rst.Fields(1) = File_Name
0079 rst.Fields(2) = File_Timestamp_Created
0080 rst.Fields(3) = Photo_Source
0081 rst.Fields(4) = File_Timestamp
0082 rst.Fields(5) = Photo_Timestamp_Manual
0083 rst.Fields(6) = File_Size
0084 rst.Fields(7) = File_Name & " (" & Photo_Source & " - " & File_Timestamp & ")"
0085 rst.Update
0086 End If
0087 iRecords_Added = iRecords_Added + 1
0088 End If
0089Next File
0090MsgBox Now() & "; Photo Import Complete. Photos added to timeline = " & iRecords_Added
0091Set rst = Nothing
0092End Sub

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



Source Code of: Cross_Reference_Add
Procedure Type: Public Function
Module: General_Functions
Lines of Code: 28
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Cross_Reference_Add(Calling_Type, Calling_ID, Calling_Timestamp, Called_Type, Called_ID, Called_Timestamp)
0002Static Note_874_Noted As Boolean
0003Dim strQuery As String
0004If Cross_Reference_Table_Open = False Then
0005 Cross_Reference_Table_Open = True
0006 strQuery = "SELECT Cross_Reference.* FROM Cross_Reference WHERE (((Cross_Reference.ID)=0));"
0007 Set rsCross_Reference_Table = CurrentDb.OpenRecordset(strQuery)
0008End If
0009If Calling_Type = "N" And Calling_ID = 874 Then
0010 If Note_874_Noted = False Then
0011 If automatic_processing <> "Yes" Then
0012 Debug.Print Now() & " - Cross_Reference_Add: No XRefs added for Test Note 874"
0013 End If
0014 Note_874_Noted = True
0015 End If
0016 Exit Function
0017End If
0018rsCross_Reference_Table.AddNew
0019 rsCross_Reference_Table.Fields(1) = Calling_Type
0020 rsCross_Reference_Table.Fields(2) = Calling_ID
0021 rsCross_Reference_Table.Fields(3) = Calling_Timestamp
0022 rsCross_Reference_Table.Fields(4) = Called_Type
0023 rsCross_Reference_Table.Fields(5) = Called_ID
0024 rsCross_Reference_Table.Fields(6) = Called_Timestamp
0025 rsCross_Reference_Table.Fields(7) = NameRef
0026 rsCross_Reference_Table.Fields(8) = Now()
0027rsCross_Reference_Table.Update
0028End Function

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



Source Code of: Functor_15
Procedure Type: Public Function
Module: Functors
Lines of Code: 185
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_15(Note_ID, Note_Title, Note_Text)
0002'Create an HTML table for a timeline
0003Dim rs As Recordset
0004Dim strQuery As String
0005Dim Note_Text_Local As String
0006Dim i As Integer
0007Dim No_Photos As Integer
0008Dim Photo_ID As Integer
0009Dim Photo_ID2 As Integer
0010Dim strDate As String
0011Dim strDate2 As String
0012Dim strComment As String
0013Dim P1_Text As String
0014Dim P1_URL As String
0015Dim P1_Percent As Integer
0016Dim P1_Alt As String
0017Dim P2_Text As String
0018Dim P2_URL As String
0019Dim P2_Percent As Integer
0020Dim P2_Alt As String
0021Dim Photo_ID_Comment As String
0022Dim Width1 As Integer
0023Dim Width2 As Integer
0024Dim Width3 As Integer
0025Dim No_Comments As Integer
0026Dim strColspan As String
0027DoEvents
0028 strQuery = "Timeline_Duplicate_Secondary_IDs"
0029Set rs = CurrentDb.OpenRecordset(strQuery)
0030If Not rs.EOF Then
0031 rs.MoveLast
0032 i = rs.RecordCount
0033 'Some IDs assumed for Second Photos clash with the IDs of First Photos
0034 If MsgBox(i & " Timeline IDs assumed for Second Photos clash with the IDs of First Photos. Proceed?", vbYesNo) = vbNo Then
0035 MsgBox ("Exiting Functor 15")
0036 Set rs = Nothing
0037 Exit Function
0038 End If
0039End If
0040DoEvents
0041Set rs = Nothing
0042Select Case Note_ID
0043 Case 1276
0044 strQuery = "Timeline_CoxesFarm"
0045 Case Else
0046 Debug.Print Now() & " - "; "Functor 15: No Timeline-query for this Note. Note ID = "; Note_ID
0047 Functor_15 = "No"
0048 Exit Function
0049End Select
0050Set rs = CurrentDb.OpenRecordset(strQuery)
0051If Not rs.EOF Then
0052 rs.MoveFirst
0053Else
0054 Functor_15 = "No"
0055 Debug.Print Now() & " - "; "Functor 15: No Timeline records for this Note. Note ID = "; Note_ID
0056 Exit Function
0057End If
0058'Create Table Header
0059Note_Text_Local = "<br><CENTER><TABLE class = ""ReadingList"" WIDTH=950>"
0060'Add rows to table
0061Do Until rs.EOF
0062 Photo_ID2 = 0
0063 'determine what to print ...
0064 strDate = Day(rs.Fields(1)) & " " & MonthName(Month(rs.Fields(1))) & " " & Year(rs.Fields(1))
0065 strDate2 = strDate
0066 Photo_ID = rs.Fields(2)
0067 strComment = rs.Fields(3) & ""
0068 P1_Text = rs.Fields(4) & ""
0069 P1_URL = rs.Fields(5) & ""
0070 P1_Percent = Nz(rs.Fields(6))
0071 P1_Alt = rs.Fields(7) & ""
0072 P2_Text = rs.Fields(8) & ""
0073 P2_URL = rs.Fields(9) & ""
0074 P2_Percent = Nz(rs.Fields(10))
0075 P2_Alt = rs.Fields(11) & ""
0076 If P2_URL = "" Then
0077 'Only one photo, so try to find another for the same row!
0078 rs.MoveNext
0079 If Not rs.EOF Then
0080 If rs.Fields(9) & "" <> "" Then
0081 'Next record has two photos, so give up!
0082 rs.MovePrevious
0083 Else
0084 strDate2 = Day(rs.Fields(1)) & " " & MonthName(Month(rs.Fields(1))) & " " & Year(rs.Fields(1))
0085 Photo_ID2 = rs.Fields(2)
0086 'Combine comments, if any
0087 If strComment <> "" Then
0088 strComment = "&larr; " & strComment
0089 If rs.Fields(3) & "" <> "" Then
0090 If strComment <> "" Then
0091 strComment = strComment & "<br>"
0092 End If
0093 strComment = strComment & rs.Fields(3) & " &rarr;"
0094 End If
0095 End If
0096 P2_Text = rs.Fields(8) & ""
0097 P2_URL = rs.Fields(9) & ""
0098 P2_Percent = Nz(rs.Fields(10))
0099 P2_Alt = rs.Fields(11) & ""
0100 End If
0101 End If
0102 End If
0103 No_Photos = 0
0104 No_Comments = 0
0105 If P1_URL <> "" Then
0106 No_Photos = 1
0107 Width1 = 33
0108 Else
0109 Width1 = 0
0110 End If
0111 If P2_URL <> "" Then
0112 No_Photos = No_Photos + 1
0113 Width3 = 33
0114 Else
0115 Width3 = 0
0116 End If
0117 If strComment <> "" Then
0118 No_Comments = 1
0119 End If
0120 If P1_Text <> "" Then
0121 No_Comments = No_Comments + 1
0122 End If
0123 If P2_Text <> "" Then
0124 No_Comments = No_Comments + 1
0125 End If
0126 If Photo_ID2 = 0 Then
0127 Photo_ID2 = Photo_ID + 1
0128 End If
0129 Select Case No_Photos
0130 Case 0
0131 Photo_ID_Comment = strDate
0132 Case 1
0133 Photo_ID_Comment = strDate & " (Photo ID = " & Photo_ID & ")"
0134 Case 2
0135 If strDate = strDate2 Then
0136 Photo_ID_Comment = strDate & " (Photo IDs = " & Photo_ID & " & " & Photo_ID2 & ")"
0137 Else
0138 Photo_ID_Comment = strDate & " (Photo ID = " & Photo_ID & ") & " & strDate & " (Photo ID = " & Photo_ID2 & ")"
0139 End If
0140 End Select
0141 Width2 = 100 - Width1 - Width3
0142 Note_Text_Local = Note_Text_Local & "<TR><TD class = ""BridgeLeft"" WIDTH=""100%"" COLSPAN=3>" & Photo_ID_Comment & "&nbsp;&darr;</TD></TR><TR>"
0143 If P1_URL <> "" Then
0144 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft"" WIDTH=""" & Width1 & "%"" ROWSPAN=" & No_Comments & ">" & "<IMG ALIGN=RIGHT ALT=""" & P1_Alt & """ TITLE=""" & P1_Alt & """ WIDTH=" & P1_Percent & "% SRC=""../../" & P1_URL & """></TD>"
0145 End If
0146 If P2_URL = "" Then
0147 strColspan = 2
0148 Else
0149 strColspan = 1
0150 End If
0151 If strComment <> "" Then
0152 Note_Text_Local = Note_Text_Local & "<TD class = """ & IIf(No_Photos <> 1, "BridgeCenter", "BridgeLeft") & """ WIDTH=""" & Width2 & "%"" colspan=" & strColspan & ">" & strComment & "</TD>"
0153 Else
0154 If P1_Text <> "" Then
0155 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft"" WIDTH=""" & Width2 & "%"" colspan=" & strColspan & ">" & P1_Text & "<br>&larr;" & "</TD>"
0156 Else
0157 If P2_Text <> "" Then
0158 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft"" WIDTH=""" & Width2 & "%"" colspan=" & strColspan & ">" & P2_Text & "<br>&rarr;" & "</TD>"
0159 Else
0160 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft"" WIDTH=""" & Width2 & "%"" colspan=" & strColspan & ">" & "&nbsp;" & "</TD>"
0161 End If
0162 End If
0163 End If
0164 If P2_URL <> "" Then
0165 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeLeft"" WIDTH=""" & Width3 & "%"" ROWSPAN=" & No_Comments & ">" & "<IMG ALIGN=LEFT ALT=""" & P2_Alt & """ TITLE=""" & P2_Alt & """ WIDTH=" & P2_Percent & "% SRC=""../../" & P2_URL & """></TD>"
0166 End If
0167 Note_Text_Local = Note_Text_Local & "</TR>"
0168 If P1_Text <> "" Then
0169 If strComment <> "" Then
0170 Note_Text_Local = Note_Text_Local & "<TR><TD class = ""BridgeLeft"" WIDTH=""" & Width2 & "%"" colspan=" & strColspan & ">" & P1_Text & "<br>&larr;" & "</TD></TR>"
0171 End If
0172 End If
0173 If P2_Text <> "" Then
0174 If No_Comments > 1 Then
0175 Note_Text_Local = Note_Text_Local & "<TR><TD class = ""BridgeRight"" WIDTH=""" & Width2 & "%"" colspan=" & strColspan & ">" & P2_Text & "<br>&rarr;" & "</TD></TR>"
0176 End If
0177 End If
0178 rs.MoveNext
0179Loop
0180'Add Table Footer
0181Note_Text_Local = Note_Text_Local & "</TABLE></CENTER>"
0182Note_Text = Note_Text_Local
0183Functor_15 = "Yes"
0184Set rs = Nothing
0185End Function

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



Source Code of: Functor_16
Procedure Type: Public Function
Module: Functors
Lines of Code: 292
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function Functor_16(Note_ID, Note_Title, Note_Text)
0002'Create an HTML table for a timeline
0003Dim rs As Recordset
0004Dim rs2 As Recordset
0005Dim strQuery As String
0006Dim Note_Text_Local As String
0007Dim Note_Text_Local_Row As String
0008Dim Width_Percent As Single
0009Dim strWidth_Percent As String
0010Dim Width_Percent_Portrait As Single
0011Dim Width_Percent_Landscape As Single
0012Const strWidth_Percent_Portrait = "**Portrait**"
0013Const strWidth_Percent_Landscape = "**Landscape**"
0014Const Photos_Per_Row = 5
0015Const Table_Width = "80%"
0016Const Portrait_Factor = 0.748898678 '340/454
0017Dim Image_Percent As String
0018Dim i As Integer
0019Dim j As Integer
0020Dim m As Integer
0021Dim n As Integer
0022Dim iLandscapes As Integer
0023Dim iPortraits As Integer
0024Dim Cell_Contents As String
0025Dim Photo_Alt As String
0026Dim Photo_Title As String
0027Dim Photo_SRC As String
0028Dim Photo_Full As String
0029Dim Photo_Type As String
0030Dim Table_Header As String
0031Dim Table_Footer As String
0032Dim Photo_Timestamp As Date
0033Dim strMonth As String
0034Dim strMonth_Saved As String
0035Dim strDate As String
0036Dim DateBanner_End As String
0037Dim DateBanner_Start As String
0038Dim strNarrative As String
0039Dim Photo_Subgroup As Integer
0040Dim Photo_Subgroup_Saved As Integer
0041Dim strTitle As String
0042Select Case Note_ID
0043 Case 1278
0044 strQuery = "Coxes_Farm_Repairs"
0045 Case 1282
0046 strQuery = "Coxes_Farm_Pre_Repairs"
0047 Case 1283
0048 strQuery = "Coxes_Farm_Gardens"
0049 Case Else
0050 Debug.Print Now() & " - "; "Functor 16: No Timeline-query for this Note. Note ID = "; Note_ID
0051 Functor_16 = "No"
0052 Exit Function
0053End Select
0054Set rs = CurrentDb.OpenRecordset(strQuery)
0055If Not rs.EOF Then
0056 rs.MoveFirst
0057 Photo_Type = rs.Fields(0)
0058Else
0059 Functor_16 = "No"
0060 Debug.Print Now() & " - "; "Functor 16: No Timeline records for this Note. Note ID = "; Note_ID
0061 Exit Function
0062End If
0063'Create the monthly jump-table - use Photo_Narratives - Photo_Subgroup 0 only
0064 strQuery = "SELECT Photo_Narratives.Photo_Type, Photo_Narratives.Photo_Year, Photo_Narratives.Photo_Month, Photo_Narratives.Photo_Narrative FROM Photo_Narratives WHERE (((Photo_Narratives.Photo_Type) = """ & Photo_Type & """) AND (Photo_Narratives.Photo_Subgroup=0)) ORDER BY Photo_Narratives.Photo_Year DESC , Photo_Narratives.Photo_Month DESC;"
0065Set rs2 = CurrentDb.OpenRecordset(strQuery)
0066If Not rs2.EOF Then
0067 rs2.MoveFirst
0068 Note_Text_Local = "<CENTER><TABLE class = ""ReadingList"" WIDTH=" & Table_Width & ">"
0069 Note_Text_Local = Note_Text_Local & "<TR><TD class = ""BridgeCenter"" COLSPAN=12><h3>Click on the links below to jump to the photos for a particular month, or scroll down. Mouse-over the date pops-up a summary of the situation that month.</h3></TD></TR>"
0070 Do Until rs2.EOF
0071 Note_Text_Local = Note_Text_Local & "<TR>"
0072 For j = 1 To 12
0073 If rs2.EOF Then
0074 Cell_Contents = "&nbsp;"
0075 Else
0076 If rs2.Fields(1) = 0 Then
0077 Cell_Contents = "Unknown Date"
0078 Else
0079 Cell_Contents = rs2.Fields(1) & "-" & Right(rs2.Fields(2) + 100, 2)
0080 End If
0081 Photo_Title = rs2.Fields(3) & ""
0082 Photo_Title = Replace(Photo_Title, "|..|", "")
0083 Photo_Title = Replace(Photo_Title, "|.|", "")
0084 Photo_Title = Replace(Photo_Title, Chr$(10), " ")
0085 Photo_Title = Replace(Photo_Title, "</a>", "")
0086 m = 1
0087 Do While m > 0
0088 m = InStr(m, Photo_Title, "<a h")
0089 If m > 0 Then
0090 n = InStr(m, Photo_Title, ">")
0091 If n > 0 Then
0092 Photo_Title = Left(Photo_Title, m - 1) & Mid(Photo_Title, n + 1)
0093 Else
0094 m = m + 1
0095 End If
0096 End If
0097 Loop
0098 Cell_Contents = "<a href=""#" & Cell_Contents & """ TITLE=""" & Photo_Title & """>" & Cell_Contents & "</a>"
0099 rs2.MoveNext
0100 End If
0101 Note_Text_Local = Note_Text_Local & "<TD class = ""BridgeCenter"" WIDTH=""" & Round(100 / 12, 2) & "%"">" & Cell_Contents & "</TD>"
0102 Next j
0103 Loop
0104 Note_Text_Local = Note_Text_Local & "</TABLE></CENTER><p>&nbsp;</p>"
0105 Set rs2 = Nothing
0106End If
0107Width_Percent = 100 / Photos_Per_Row
0108strMonth_Saved = ""
0109Photo_Subgroup_Saved = 0
0110'Create Table Header & Footer & save for future use
0111Table_Header = "<CENTER><TABLE class = ""ReadingList"" WIDTH=" & Table_Width & ">"
0112Table_Footer = "</TABLE></CENTER>"
0113DateBanner_Start = "<TR><TD class = ""BridgeLeft"" COLSPAN=" & Photos_Per_Row & ">"
0114DateBanner_End = "</TD></TR>"
0115Photo_Timestamp = rs.Fields(5)
0116If Photo_Timestamp = 0 Then
0117 Photo_Timestamp = rs.Fields(4)
0118End If
0119Photo_Subgroup = rs.Fields(14)
0120strMonth = Year(Photo_Timestamp) & " - " & MonthName(Month(Photo_Timestamp))
0121strMonth_Saved = strMonth
0122 strQuery = "SELECT Photo_Narratives.Photo_Type, Photo_Narratives.Photo_Year, Photo_Narratives.Photo_Month, Photo_Narratives.Photo_Subgroup, Photo_Narratives.Photo_Narrative, Photo_Narratives.Photo_Title FROM Photo_Narratives WHERE (((Photo_Narratives.Photo_Type)=""" & rs.Fields(0) & """) AND ((Photo_Narratives.Photo_Year)=" & Year(Photo_Timestamp) & ") AND ((Photo_Narratives.Photo_Month)=" & Month(Photo_Timestamp) & ") AND ((Photo_Narratives.Photo_Subgroup)=" & Photo_Subgroup & "));"
0123Set rs2 = CurrentDb.OpenRecordset(strQuery)
0124If rs2.EOF Then
0125 strNarrative = ""
0126 strTitle = ""
0127 'Add a dummy for next time!
0128 rs2.AddNew
0129 rs2.Fields(0) = rs.Fields(0)
0130 rs2.Fields(3) = Photo_Subgroup
0131 rs2.Fields(4) = ""
0132 If Photo_Timestamp = 0 Then
0133 rs2.Fields(1) = 0
0134 rs2.Fields(2) = 0
0135 Else
0136 rs2.Fields(1) = Year(Photo_Timestamp)
0137 rs2.Fields(2) = Month(Photo_Timestamp)
0138 End If
0139 rs2.Update
0140Else
0141 strNarrative = rs2.Fields(4) & ""
0142 strTitle = rs2.Fields(5) & ""
0143End If
0144'Add internal and external link-tags
0145strDate = Year(Photo_Timestamp) & "-" & Right(Month(Photo_Timestamp) + 100, 2)
0146strDate = "+R" & strDate & "R+" & "<a name=""" & strDate & """></a>"
0147Note_Text_Local = Note_Text_Local & strDate
0148'Output the first header
0149Note_Text_Local = Note_Text_Local & Table_Header
0150strDate = Year(Photo_Timestamp) & "-" & Right(Month(Photo_Timestamp) + 100, 2)
0151 strQuery = "SELECT Photo_Narratives.Photo_Type, Photo_Narratives.Photo_Year, Photo_Narratives.Photo_Month, Photo_Narratives.Photo_Subgroup, Photo_Narratives.Photo_Narrative, Photo_Narratives.Photo_Title FROM Photo_Narratives WHERE (((Photo_Narratives.Photo_Type)=""" & rs.Fields(0) & """) AND ((Photo_Narratives.Photo_Year)=" & Year(Photo_Timestamp) & ") AND ((Photo_Narratives.Photo_Month)=" & Month(Photo_Timestamp) & ") AND ((Photo_Narratives.Photo_Subgroup)=" & Photo_Subgroup & "));"
0152If strTitle <> "" Then
0153 strTitle = " - " & strTitle
0154End If
0155Note_Text_Local = Note_Text_Local & DateBanner_Start & "<h1>" & strMonth & strTitle & "</h1>" & strNarrative
0156Note_Text_Local = Note_Text_Local & DateBanner_End
0157'Add rows to table
0158Do Until rs.EOF
0159 Note_Text_Local_Row = Table_Footer & Table_Header
0160 Note_Text_Local_Row = Note_Text_Local_Row & "<TR>"
0161 iLandscapes = 0
0162 iPortraits = 0
0163 For i = 1 To Photos_Per_Row
0164 If Not rs.EOF Then
0165 Photo_Timestamp = rs.Fields(5)
0166 Photo_Subgroup = rs.Fields(14)
0167 If Photo_Timestamp = 0 Then
0168 Photo_Timestamp = rs.Fields(4)
0169 End If
0170 If Photo_Timestamp = 0 Then
0171 strMonth = "Unknown Date"
0172 Else
0173 strMonth = Year(Photo_Timestamp) & " - " & MonthName(Month(Photo_Timestamp))
0174 End If
0175 If (strMonth <> strMonth_Saved) Or Photo_Subgroup <> Photo_Subgroup_Saved Then
0176 If i <> 1 Then
0177 For j = i To Photos_Per_Row
0178 Cell_Contents = "&nbsp;"
0179 iLandscapes = iLandscapes + 1
0180 Note_Text_Local_Row = Note_Text_Local_Row & "<TD class = ""BridgeRight"" STYLE=""width:" & strWidth_Percent_Landscape & "%"">" & Cell_Contents & "</TD>"
0181 Next j
0182 End If
0183 If (Note_Text_Local_Row = "<TR>") Or (Note_Text_Local_Row = Table_Footer & Table_Header & "<TR>") Then
0184 If Note_Text_Local_Row = "<TR>" Then
0185 Note_Text_Local_Row = ""
0186 End If
0187 Else
0188 'Calculate Width_Percents
0189 Width_Percent_Landscape = iLandscapes + iPortraits * Portrait_Factor
0190 Width_Percent_Landscape = 100 / Width_Percent_Landscape
0191 Width_Percent_Portrait = Width_Percent_Landscape * Portrait_Factor
0192 Width_Percent_Portrait = Round(Width_Percent_Portrait, 2)
0193 Width_Percent_Landscape = Round(Width_Percent_Landscape, 2)
0194 'Replace dummy Width_Percents
0195 Note_Text_Local_Row = Replace(Note_Text_Local_Row, strWidth_Percent_Landscape, Width_Percent_Landscape)
0196 Note_Text_Local_Row = Replace(Note_Text_Local_Row, strWidth_Percent_Portrait, Width_Percent_Portrait)
0197 'End the row
0198 Note_Text_Local_Row = Note_Text_Local_Row & "</TR>"
0199 End If
0200 Note_Text_Local = Note_Text_Local & Note_Text_Local_Row & Table_Footer & "<p>&nbsp;</p>"
0201 Note_Text_Local_Row = ""
0202 If Photo_Timestamp = 0 Then
0203 strDate = "Unknown Date"
0204 strQuery = "SELECT Photo_Narratives.Photo_Type, Photo_Narratives.Photo_Year, Photo_Narratives.Photo_Month, Photo_Narratives.Photo_Subgroup, Photo_Narratives.Photo_Narrative, Photo_Narratives.Photo_Title FROM Photo_Narratives WHERE (((Photo_Narratives.Photo_Type)=""" & rs.Fields(0) & """) AND ((Photo_Narratives.Photo_Year)=0) AND ((Photo_Narratives.Photo_Month)=0) AND ((Photo_Narratives.Photo_Subgroup)=" & Photo_Subgroup & "));"
0205 Else
0206 strDate = Year(Photo_Timestamp) & "-" & Right(Month(Photo_Timestamp) + 100, 2)
0207 strQuery = "SELECT Photo_Narratives.Photo_Type, Photo_Narratives.Photo_Year, Photo_Narratives.Photo_Month, Photo_Narratives.Photo_Subgroup, Photo_Narratives.Photo_Narrative, Photo_Narratives.Photo_Title FROM Photo_Narratives WHERE (((Photo_Narratives.Photo_Type)=""" & rs.Fields(0) & """) AND ((Photo_Narratives.Photo_Year)=" & Year(Photo_Timestamp) & ") AND ((Photo_Narratives.Photo_Month)=" & Month(Photo_Timestamp) & ") AND ((Photo_Narratives.Photo_Subgroup)=" & Photo_Subgroup & "));"
0208 End If
0209 If Photo_Subgroup <> 0 And strMonth = strMonth_Saved Then
0210 strDate = strDate & "-" & Photo_Subgroup
0211 End If
0212 strDate = "+R" & strDate & "R+" & "<a name=""" & strDate & """></a>"
0213 Note_Text_Local = Note_Text_Local & strDate
0214 Note_Text_Local = Note_Text_Local & Table_Header
0215 Set rs2 = CurrentDb.OpenRecordset(strQuery)
0216 If rs2.EOF Then
0217 strNarrative = ""
0218 strTitle = ""
0219 'Add a dummy for next time!
0220 rs2.AddNew
0221 rs2.Fields(0) = rs.Fields(0)
0222 rs2.Fields(3) = Photo_Subgroup
0223 rs2.Fields(4) = ""
0224 If Photo_Timestamp = 0 Then
0225 rs2.Fields(1) = 0
0226 rs2.Fields(2) = 0
0227 Else
0228 rs2.Fields(1) = Year(Photo_Timestamp)
0229 rs2.Fields(2) = Month(Photo_Timestamp)
0230 End If
0231 rs2.Update
0232 Else
0233 strNarrative = rs2.Fields(4) & ""
0234 strTitle = rs2.Fields(5) & ""
0235 End If
0236 If strTitle <> "" Then
0237 strTitle = " - " & strTitle
0238 End If
0239 Note_Text_Local = Note_Text_Local & DateBanner_Start & "<h1>" & strMonth & strTitle & "</h1>" & strNarrative
0240 Note_Text_Local = Note_Text_Local & DateBanner_End
0241 i = 1
0242 strMonth_Saved = strMonth
0243 Photo_Subgroup_Saved = Photo_Subgroup
0244 End If
0245 Photo_Alt = ""
0246 Photo_Title = rs.Fields(7) & ""
0247 'Need to remove any hyperlinks
0248 Photo_Title = Remove_Hyperlinks(Photo_Title)
0249 Photo_SRC = rs.Fields(10) & ""
0250 Photo_Full = rs.Fields(1)
0251 If Photo_SRC = "" Then
0252 Photo_SRC = Photo_Full
0253 End If
0254 'Determine Photo Orientation
0255 If rs.Fields(15) = True Then
0256 strWidth_Percent = strWidth_Percent_Portrait
0257 iPortraits = iPortraits + 1
0258 Image_Percent = 100
0259 Image_Percent = Round(100 * Portrait_Factor, 2)
0260 Else
0261 strWidth_Percent = strWidth_Percent_Landscape
0262 Image_Percent = 100
0263 iLandscapes = iLandscapes + 1
0264 End If
0265 Cell_Contents = "<IMG ALIGN=CENTER ALT=""" & Photo_Alt & """ TITLE=""" & Photo_Title & """ WIDTH=" & Image_Percent & "% SRC=""" & Photo_SRC & """>"
0266 Cell_Contents = "<A HREF=""" & Photo_Full & """>" & Cell_Contents & "</A><br>" & rs.Fields(12) & ""
0267 Else
0268 Cell_Contents = "&nbsp;"
0269 iLandscapes = iLandscapes + 1
0270 End If
0271 Note_Text_Local_Row = Note_Text_Local_Row & "<TD class = ""BridgeLeft"" STYLE=""width:" & strWidth_Percent & "%"">" & Cell_Contents & "</TD>"
0272 If Not rs.EOF Then
0273 rs.MoveNext
0274 End If
0275 Next i
0276 'Calculate Width_Percents
0277 Width_Percent_Landscape = iLandscapes + iPortraits * Portrait_Factor
0278 Width_Percent_Landscape = 100 / Width_Percent_Landscape
0279 Width_Percent_Portrait = Width_Percent_Landscape * Portrait_Factor
0280 Width_Percent_Portrait = Round(Width_Percent_Portrait, 2)
0281 Width_Percent_Landscape = Round(Width_Percent_Landscape, 2)
0282 'Replace dummy Width_Percents
0283 Note_Text_Local_Row = Replace(Note_Text_Local_Row, strWidth_Percent_Landscape, Width_Percent_Landscape)
0284 Note_Text_Local_Row = Replace(Note_Text_Local_Row, strWidth_Percent_Portrait, Width_Percent_Portrait)
0285 Note_Text_Local = Note_Text_Local & Note_Text_Local_Row & "</TR>"
0286Loop
0287Note_Text_Local = Note_Text_Local & Table_Footer
0288Note_Text = Note_Text_Local
0289Functor_16 = "Yes"
0290Set rs = Nothing
0291Set rs2 = Nothing
0292End Function

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



Source Code of: GetProperty
Procedure Type: Public Function
Module: Timelines
Lines of Code: 21
Go To End of This Procedure

Line-No. / Ref.Code Line
0001Public Function GetProperty(strPath, strFileName, n)
0002Dim objShell
0003Dim objFolder
0004Dim objFolderItem
0005'Function found on the Web for extracting properties from files. Modified slightly. Not sure quite why it works.
0006On Error GoTo ErrHandler
0007Set objShell = CreateObject("Shell.Application")
0008Set objFolder = objShell.Namespace(strPath)
0009Set objFolderItem = objFolder.ParseName(strFileName)
0010If Not objFolderItem Is Nothing Then
0011 GetProperty = objFolder.GetDetailsOf(objFolderItem, n)
0012End If
0013ExitHandler:
0014Set objFolderItem = Nothing
0015Set objFolder = Nothing
0016Set objShell = Nothing
0017Exit Function
0018ErrHandler:
0019MsgBox Err.Description, vbExclamation
0020Resume ExitHandler
0021End Function

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



© Theo Todman, June 2007 - Apr 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