'MacroName:Auth046 'MacroDescription:Copy dates from 100 $d to 046 $f and $g 'Macro written by: Joel Hahn, Niles Public Library District 'Last modified: 6 Nov 2012 Option Explicit Declare Function CvtDate(sDate As String) As String Sub Main Dim bool As Integer Dim sName, s046, sExisting046, sExistingF, sExistingG, sTempDates, sDate1, sDate2 As String Dim place As Integer Dim CS As Object On Error Resume Next Set CS = GetObject(,"Connex.Client") On Error GoTo 0 If CS Is Nothing Then Set CS = CreateObject("Connex.Client") End If If InStr(",3,4,18,", "," & CStr(CS.ItemType) & ",") Then 'Viewing an authority record 'Check for 100 field bool = CS.GetField("100", 1, sName) If bool = FALSE Then MsgBox "Not viewing a personal name authority record. Exiting..." Exit Sub End If 'Check for existing 045 f & g sExisting046 = "N" sExistingF = "N" sExistingG = "N" bool = CS.GetField("046", 1, s046) If bool = TRUE Then sExisting046 = "Y" If InStr(s046, Chr(223) & "f") Then sExistingF = "Y" If InStr(s046, Chr(223) & "g") Then sExistingG = "Y" If Trim(Right(s046, 7)) = Chr(223) & "f " & Chr(223) & "g" Then s046 = Left(s046, Len(s046) - 7) sExistingF = "N" sExistingG = "N" End If If sExistingF = "Y" And sExistingG = "Y" Then MsgBox "Authority record already contains both 046 $f and $g. Exiting..." Exit Sub End If End If 'Get dates from 100 field place = InStr(sName, Chr(223) & "d") If place = 0 Then MsgBox "Name heading does not include any dates. Exiting..." Exit Sub End If sTempDates = Trim(Mid(sName, place + 2)) If InStr(sTempDates, Chr(223)) Then place = InStr(sTempDates, Chr(223)) sTempDates = Trim(Left(sTempDates, place - 1)) End If If Right(sTempDates, 1) = "." or Right(sTempDates, 1) = "," Then sTempDates = Left(sTempDates, Len(sTempDates) - 1) 'Split dates into birth date & death date If InStr(sTempDates, "-") Then place = InStr(sTempDates, "-") sDate1 = Trim(Left(sTempDates, place - 1)) If place < Len(sTempDates) Then sDate2 = Trim(Mid(sTempDates, place + 1)) End If ElseIf InStr(sTempDates, "B.C") Then MsgBox "Unable to copy B.C. dates to 046. Exiting..." Exit Sub ElseIf Left(sTempDates, 2) = "b." Then sDate1 = Trim(Mid(sTempDates, 3)) sDate2 = "" ElseIf UCase(Left(sTempDates, 4)) = "BORN" Then sDate1 = Trim(Mid(sTempDates, 5)) sDate2 = "" ElseIf Left(sTempDates, 2) = "d." Then sDate1 = "" sDate2 = Trim(Mid(sTempDates, 3)) ElseIf UCase(Left(sTempDates, 4)) = "DIED" Then sDate1 = "" sDate2 = Trim(Mid(sTempDates, 5)) ElseIf Left(sTempDates, 3) = "fl." or InStr(UCase(sTempDates), " CEN.") Or InStr(UCase(sTempDates), " CENT") or InStr(UCase(sTempDates), "ACTIVE") or InStr(UCase(sTempDates), "FLOURISHED") Then 'Don't convert flourished dates and approximate centuries into birth/death dates 'These should go in $s and $t MsgBox "Cannot copy dates of activity as dates of birth/death. Exiting..." Exit Sub Else 'Unhandleable case, do nothing MsgBox "Unknown date format in 100 $d. Exiting..." Exit Sub End If If sDate1 <> "" Then sDate1 = CvtDate(sDate1) If sDate2 <> "" Then sDate2 = CvtDate(sDate2) 'MsgBox "1: " & sDate1 & Chr(10) & "2: " & sDate2 If s046 = "" Then s046 = "046 " If sDate1 <> "" and sExistingF = "N" Then s046 = s046 & " " & Chr(223) & "f " & sDate1 If sDate2 <> "" and sExistingG = "N" Then s046 = s046 & " " & Chr(223) & "g " & sDate2 If sExisting046 = "Y" Then bool = CS.SetField(1, s046) Else bool = CS.AddField(1, s046) End If Else MsgBox "Not viewing an authority record" Exit Sub End If End Sub Function CvtDate(sDate As String) As String Dim sTempDate, sUncertain, sApprox, sTempYear1, sTempYear2, sTempMon, sTempDay As String Dim place as Integer If Right(sDate, 1) = "?" Then sUncertain = "Y" sDate = Left(sDate, Len(sDate) - 1) End If If Left(sDate, 3) = "ca." Then sApprox = "Y" sDate = Trim(Mid(sDate, 4)) ElseIf Left(UCase(sDate), 6) = "APPROX" Then sApprox = "Y" sDate = Trim(Mid(sDate, 14)) End If If InStr(UCase(sDate), "A.D") Then place = InStr(UCase(sDate), "A.D") sDate = Trim(Left(sDate, place-1)) End If If (Len(sDate) = 1 And sDate Like "[1-9]") _ Or (Len(sDate) = 2 And sDate Like "[1-9][0-9]") _ Or (Len(sDate) = 3 And sDate Like "[1-9][0-9][0-9]") _ Or (Len(sDate) = 4 And sDate Like "[1-9][0-9][0-9][0-9]") Then sTempDate = Right("0000" & sDate, 4) ElseIf InStr(UCase(sDate), " OR ") Then 'Multiple contiguous dates place = InStr(UCase(sDate), " OR ") sTempYear1 = Left(sDate, place - 1) sTempYear2 = Mid(sDate, place + 4) If Len(sTempYear2) < Len(sTempyear1) Then sTempyear2 = Left(sTempYear1, Len(sTempYear1)-Len(sTempYear2)) & sTempYear2 sTempDate = "[" & sTempYear1 & "," & sTempYear2 & "] " & Chr(223) & "2 edtf" ElseIf InStr(UCase(sDate), " JAN") Or InStr(UCase(sDate), " FEB") Or InStr(UCase(sDate), " MAR") _ Or InStr(UCase(sDate), " APR") Or InStr(UCase(sDate), " MAY") Or InStr(UCase(sDate), " JUN") _ Or InStr(UCase(sDate), " JUL") Or InStr(UCase(sDate), " AUG") Or InStr(UCase(sDate), " SEP") _ Or InStr(UCase(sDate), " OCT") Or InStr(UCase(sDate), " NOV") Or InStr(UCase(sDate), " DEC") Then 'Date with month place = InStr(sDate, " ") sTempYear1 = Left(sDate, place - 1) sTempYear2 = Mid(sDate, place + 1) place = InStr(sTempYear2, " ") sTempMon = Left(sTempYear2, place - 1) sTempDay = Right("00" & Mid(sTempYear2, place + 1), 2) Select Case UCase(Left(sTempMon, 3)) Case "JAN" sTempMon = "01" Case "FEB" sTempMon = "02" Case "MAR" sTempMon = "03" Case "APR" sTempMon = "04" Case "MAY" sTempMon = "05" Case "JUN" sTempMon = "06" Case "JUL" sTempMon = "07" Case "AUG" sTempMon = "08" Case "SEP" sTempMon = "09" Case "OCT" sTempMon = "10" Case "NOV" sTempMon = "11" Case "DEC" sTempMon = "12" Case Else sTempMon = "--" End Select sTempDate = Right("0000" & sTempYear1, 4) & sTempMon & sTempDay Else 'Unknown case sTempDate = sDate End If If sUncertain = "Y" Then sTempDate = sTempDate & "?" End If If sApprox = "Y" Then sTempDate = sTempDate & "~" End If If sUncertain = "Y" Or sApprox = "Y" Then sTempDate = stempDate & " " & Chr(223) & "2 edtf" End If CvtDate = sTempDate End Function