Permalink
Browse files

Form_Accessions, cAccnScan / allow source folder for a scan to determ…

…ine CabinetFolder setting, or dest folder.
  • Loading branch information...
C. Johnson
C. Johnson committed Apr 24, 2018
1 parent 1b365c5 commit 21b22926418b5aec005e8fb2ac57f4d2e0c20e73
Showing with 114 additions and 83 deletions.
  1. +60 −23 Form_Accessions.cls
  2. +54 −60 cAccnScan.cls
@@ -71,6 +71,7 @@ Private Sub cmdAddScan_Click()
Dim sLocator As Variant
Dim sPrevious As String
Dim sFilePath As String
Dim asFileFolderSlugs(1 To 2) As String
Dim sFileName As String
Dim bWasNewRecord As Boolean
Dim bAttachmentError As Boolean
@@ -91,9 +92,12 @@ Private Sub cmdAddScan_Click()
Set oAccnScan = New cAccnScan: With oAccnScan
.Url = sItem
End With
Let asFileFolderSlugs(1) = oAccnScan.FileFolderSlug
If Not oAccnScan.isOnDefaultDrive Then
If Len(sDestinationFolder) = 0 Then
Set dlgDestinationFolder = Application.FileDialog(msoFileDialogFolderPicker): With dlgDestinationFolder
.Title = "Destination Folder"
End With
@@ -106,6 +110,7 @@ Private Sub cmdAddScan_Click()
If Len(sDestinationFolder) > 0 Then
oAccnScan.doCopyTo NewPath:=sDestinationFolder
Let sItem = oAccnScan.Url
Let asFileFolderSlugs(2) = oAccnScan.FileFolderSlug
End If
End If
@@ -145,7 +150,7 @@ AttachToRecordCatch:
If Me.NewRecord Then
AccnScanListView.View FileName:=sItem
DoFillOutAndSave FileName:=sItem, OK:=Fixed
DoFillOutAndSave FileName:=sItem, Slugs:=asFileFolderSlugs, OK:=Fixed
End If
End If
@@ -157,10 +162,13 @@ AttachToRecordCatch:
End If
End Sub
Private Sub DoFillOutAndSave(ByVal FileName As String, ByRef OK As Boolean)
Private Sub DoFillOutAndSave(ByVal FileName As String, ByRef Slugs() As String, ByRef OK As Boolean)
Dim I As Integer
Dim sDetails As String
Dim rDetails As AccessionDetails
Dim oFolder As cCabinetFolder
FillOutFormFromAttachment FileName
If Len(Nz(Me!ACCN.value)) = 0 Then
Let sDetails = InputBox("Accession Number")
@@ -188,7 +196,36 @@ Private Sub DoFillOutAndSave(ByVal FileName As String, ByRef OK As Boolean)
Let Me!AddedToDatabaseBy.value = getUserName
Let Me!AddedToDatabaseOn.value = Now
Let Me!CabinetFolder.value = sLastCabinetFolderLabel
Set oFolder = New cCabinetFolder: With oFolder
.FileSourcePath = ""
End With
For I = LBound(Slugs) To UBound(Slugs)
If Len(Slugs(I)) > 0 Then
Set oFolder = New cCabinetFolder: With oFolder
.FileSourcePath = Slugs(I)
End With
If oFolder.ID <> 0 Then
Let Me!CabinetFolder.value = oFolder.Label
Exit For
Else
Set oFolder = New cCabinetFolder: With oFolder
.FilePath = Slugs(I)
End With
If oFolder.ID <> 0 Then
Let Me!CabinetFolder.value = oFolder.Label
Exit For
End If
End If
End If
Next I
If Len(Nz(Me!CabinetFolder.value)) = 0 Then
Let Me!CabinetFolder.value = sLastCabinetFolderLabel
End If
On Error GoTo cmdSaveRecordCatch
DoCmd.RunCommand acCmdSaveRecord
@@ -206,7 +243,7 @@ cmdSaveRecordCatch:
End Sub
Private Function GetDetails(ByVal File As String, Optional ByVal s As String) As AccessionDetails
Dim i As Integer
Dim I As Integer
Dim aParts() As String
Dim oAx As New cAccession
@@ -221,31 +258,31 @@ Private Function GetDetails(ByVal File As String, Optional ByVal s As String) As
Let aParts = Split(s, "/")
If UBound(aParts) > LBound(aParts) Then
Let i = LBound(aParts)
Let oAx.ACCN = aParts(i)
Let I = LBound(aParts)
Let oAx.ACCN = aParts(I)
Let i = LBound(aParts) + 1
Let I = LBound(aParts) + 1
If CLng(oAx.Minor) = 0 Then
Let oAx.ACCN = aParts(i) & "." & oAx.Major
Let oAx.ACCN = aParts(I) & "." & oAx.Major
End If
Let rDetails.ACCN = oAx.ACCN
'Get the YYYY from the major part of the Accession number
Let sDate = Format(oAx.Major, "0000")
'Get remaining date elements from the string
If aParts(i) <> sDate Then
If RegexMatch(aParts(i), "^[0-9]{4}$") Then
If CInt(aParts(i)) <= 1231 Then
Let aParts(i) = Left(aParts(i), 2) & "/" & Right(aParts(i), 2)
If aParts(I) <> sDate Then
If RegexMatch(aParts(I), "^[0-9]{4}$") Then
If CInt(aParts(I)) <= 1231 Then
Let aParts(I) = Left(aParts(I), 2) & "/" & Right(aParts(I), 2)
End If
End If
Let sDate = sDate & "/" & aParts(i)
Let sDate = sDate & "/" & aParts(I)
End If
For i = LBound(aParts) + 2 To UBound(aParts)
Let sDate = sDate & "/" & aParts(i)
Next i
For I = LBound(aParts) + 2 To UBound(aParts)
Let sDate = sDate & "/" & aParts(I)
Next I
Let rDetails.Date = CDate(sDate)
ElseIf Len(s) > 0 Then
@@ -514,12 +551,12 @@ Private Sub FillOutFormFromAttachmentControls()
'SOURCE CONTROL 1: Me!Scan, an Attachment field control
If Me!Scan.AttachmentCount > 0 Then
Me!Scan.CurrentAttachment = 0
For i = 0 To (Me!Scan.AttachmentCount - 1)
For I = 0 To (Me!Scan.AttachmentCount - 1)
If regexpIsAccnScanFile.Test(Me!ScanFileName) Then
cAttachPaths.Add Me!ScanFileName
End If
Me!Scan.Forward
Next i
Next I
End If
'SOURCE CONTROL 2: Me!lstAccnScans, via AccnScanListView object
@@ -578,9 +615,9 @@ Private Sub FillCurNames()
aScanDir(1) = "State"
aScanDir(2) = "Local"
For i = 1 To 1
For I = 1 To 1
sPattern = "*_*"
sDirPrefix = "\CollectionsManagement\AgencyFiles\" & aScanDir(i) & "\"
sDirPrefix = "\CollectionsManagement\AgencyFiles\" & aScanDir(I) & "\"
f = Dir(sDrive & sDirPrefix & sPattern, vbDirectory)
Do While Len(f) > 0
@@ -593,7 +630,7 @@ Private Sub FillCurNames()
End If
f = Dir()
Loop
Next i
Next I
Dim dCurNamesNoted As Dictionary
Set dCurNamesNoted = CurNamesInCreators
@@ -65,72 +65,66 @@ Public Property Get PathStart() As String
End Property
Public Property Get FileFolder()
Dim myPath As String
Dim aFolders() As String
Dim prevFolder As String
Dim curFolder As Variant
Dim myFolder As String
Dim oFolder As cCabinetFolder
myPath = FilePath
aFolders = Split(myPath, "\")
Set oFolder = New cCabinetFolder: With oFolder
.FilePath = FileFolderSlug
End With
If UBound(aFolders) > 0 Then
If UBound(aFolders) - LBound(aFolders) > 0 Then
myFolder = aFolders(UBound(aFolders) - 1)
Else
myFolder = aFolders(UBound(aFolders))
End If
Set oFolder = New cCabinetFolder
Let oFolder.FilePath = myFolder
If oFolder.ID = 0 Then
oFolder.Insert
End If
If oFolder.ID <> 0 Then
myFolder = oFolder.Label
End If
If oFolder.ID = 0 Then
oFolder.Insert
End If
Else
myFolder = ""
If oFolder.ID <> 0 Then
Let FileFolder = oFolder.Label
End If
'
'prevFolder = ""
'For Each curFolder In aFolders
' myFolder = prevFolder & " " & JoinCollection(" ", camelCaseSplitString(curFolder & ""))
'
' 'when we move to the next curFolder, preserve this one as previous
' prevFolder = JoinCollection(" ", camelCaseSplitString(curFolder & ""))
'Next curFolder
End Property
Public Function FileFolderSlug() As String
Dim myPath As String
Dim I As Integer
Dim sSlug As String
Dim asFolders() As String
FileFolder = myFolder
Let myPath = FilePath
Let asFolders = Split(myPath, "\")
End Property
If UBound(asFolders) >= LBound(asFolders) Then
Let I = UBound(asFolders)
Do Until (Len(sSlug) > 0) Or (I < LBound(asFolders))
If Not RegexMatch(asFolders(I), "Cont[r]?ol\s*File[s]?") Then
Let sSlug = asFolders(I)
End If
Let I = I - 1
Loop
End If
Let FileFolderSlug = sSlug
End Function
Public Property Let Url(sUrl As String)
Dim aPath() As String
Dim sPath As String
Dim i As Integer
Dim I As Integer
aPath = Split(sUrl, "\")
FileName = aPath(UBound(aPath))
sDrive = ""
sPath = ""
For i = LBound(aPath) To UBound(aPath) - 1
If Right(aPath(i), 1) = ":" Then
sDrive = aPath(i)
ElseIf Len(aPath(i)) = 0 Then
For I = LBound(aPath) To UBound(aPath) - 1
If Right(aPath(I), 1) = ":" Then
sDrive = aPath(I)
ElseIf Len(aPath(I)) = 0 Then
'NOOP
ElseIf (Len(sDrive) = 0) And (aPath(i) = PathStart) Then
ElseIf (Len(sDrive) = 0) And (aPath(I) = PathStart) Then
sDrive = "\" & sPath
sPath = "\" & aPath(i)
sPath = "\" & aPath(I)
Else
sPath = sPath & "\" & aPath(i)
sPath = sPath & "\" & aPath(I)
End If
Next i
Next I
FilePath = sPath
End Property
@@ -231,7 +225,7 @@ Public Function Creator() As String
Dim cWords As Collection
Dim sSlug As String
Dim aPath() As String
Dim i As Integer
Dim I As Integer
Set oRefs = MetadataFromFileName
@@ -240,18 +234,18 @@ Public Function Creator() As String
Creator = oRefs(0)
Else
Let aPath = Split(FilePath, "\")
Let i = UBound(aPath)
Let I = UBound(aPath)
If i >= LBound(aPath) Then
If RegexMatch(aPath(i), "^Contr?olFiles?$") Then
Let i = i - 1
If I >= LBound(aPath) Then
If RegexMatch(aPath(I), "^Contr?olFiles?$") Then
Let I = I - 1
End If
End If
If i >= LBound(aPath) Then
Let Creator = aPath(i)
If I >= LBound(aPath) Then
Let Creator = aPath(I)
Let sSlug = aPath(i)
Let sSlug = aPath(I)
Set cWords = camelCaseSplitString(sSlug)
If cWords.Count > 0 Then
@@ -425,7 +419,7 @@ Public Sub ConvertFileName(ByRef Result As String)
Dim sNewFileName As String
Dim oRef As Variant
Dim cRefs As Variant
Dim i As Integer
Dim I As Integer
Dim sOldFull As String
Dim sNewFull As String
@@ -482,8 +476,8 @@ FinallyRename:
CatchRename:
Debug.Print "DID/COULD NOT RENAME: ", Url, "TRY AGAIN..."
Let sOldNew = sNewFileName
Let i = i + 1
Let sNewFileName = MetaD.Item(0) & MetaD.Item(1) & MetaD.Item(2) & MetaD.Item(6) & "-" & Format(i, "00") & ".PDF" & MetaD.Item(7)
Let I = I + 1
Let sNewFileName = MetaD.Item(0) & MetaD.Item(1) & MetaD.Item(2) & MetaD.Item(6) & "-" & Format(I, "00") & ".PDF" & MetaD.Item(7)
If sOldNew <> sNewFileName Then Resume TryRename
Resume FinallyRename
@@ -499,10 +493,10 @@ Public Function isOnDefaultDrive() As Boolean
Set FO(2) = FSO.GetFolder(getDefaultDrive & "\")
'We need to account for the possibility of mapped network drives
Dim i As Integer
For i = 1 To 2
Let driveNames(i) = IIf(Len(FO(i).Drive.ShareName) > 0, FO(i).Drive.ShareName, FO(i).Drive.Path)
Next i
Dim I As Integer
For I = 1 To 2
Let driveNames(I) = IIf(Len(FO(I).Drive.ShareName) > 0, FO(I).Drive.ShareName, FO(I).Drive.Path)
Next I
Let isOnDefaultDrive = (driveNames(1) = driveNames(2))
End Function
@@ -532,7 +526,7 @@ Private Function retrieveScanFilePath()
Dim vScanDir As Variant
Dim cScanDirs As New Collection
Dim sDirPrefix As String
Dim i As Integer
Dim I As Integer
cScanDirs.Add "\AgencyState"
cScanDirs.Add "\AgencyLocal"

0 comments on commit 21b2292

Please sign in to comment.