Permalink
Browse files

Form_Accessions, cAccnScan / bulk adding images, allow use of path in…

…formation in CabinetFolders table to determine destination path without having to navigate a file picker.
  • Loading branch information...
C. Johnson
C. Johnson committed Apr 24, 2018
1 parent 21b2292 commit c20f6e5f8bdabbc35cb991e7fcee488d61491e61
Showing with 56 additions and 27 deletions.
  1. +4 −1 Form_Accessions.cls
  2. +4 −1 cAccession.cls
  3. +48 −25 cAccnScan.cls
@@ -97,7 +97,10 @@ Private Sub cmdAddScan_Click()
If Not oAccnScan.isOnDefaultDrive Then
If Len(sDestinationFolder) = 0 Then
Let sDestinationFolder = oAccnScan.FolderHomePath
End If
If Len(sDestinationFolder) = 0 Then
Set dlgDestinationFolder = Application.FileDialog(msoFileDialogFolderPicker): With dlgDestinationFolder
.Title = "Destination Folder"
End With
@@ -106,7 +109,7 @@ Private Sub cmdAddScan_Click()
Let sDestinationFolder = dlgDestinationFolder.SelectedItems(1)
End If
End If
If Len(sDestinationFolder) > 0 Then
oAccnScan.doCopyTo NewPath:=sDestinationFolder
Let sItem = oAccnScan.Url
@@ -85,6 +85,9 @@ Public Property Let Major(s As String)
If canUseForMajor(s) Then
Let iMajor = CLng(s)
If iMajor < 1900 And Len(s) = 2 Then
Let iMajor = 1900 + iMajor
End If
Let sMajor = Format(iMajor, MajorFormat)
Else
Let sMajor = ""
@@ -197,7 +200,7 @@ Private Sub RetrieveAttachmentsFromDB()
Dim Rs As DAO.Recordset
Dim oQuery As DAO.QueryDef
Dim i As Integer, iCount As Integer
Dim I As Integer, iCount As Integer
'check the database for comments flagged with this CollectionNumber
On Error Resume Next: CurrentDb.QueryDefs.Delete "qScanFilesByAccn": On Error GoTo 0
@@ -106,17 +106,27 @@ End Function
Public Property Let Url(sUrl As String)
Dim aPath() As String
Dim sPath As String
Dim iStartPath 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
Let iStartPath = LBound(aPath)
If RegexMatch(Left(sUrl, 2), "[A-Za-z][:]") Then
Let sDrive = Left(sUrl, 2)
Let iStartPath = iStartPath + 1
ElseIf Left(sUrl, 2) = "\\" Or Left(sUrl, 2) = "//" Then
Let sDrive = "\\" & aPath(iStartPath + 2) & "\" & aPath(iStartPath + 3)
Let iStartPath = iStartPath + 4
End If
For I = iStartPath To UBound(aPath) - 1
If Len(aPath(I)) = 0 Then
'NOOP
ElseIf (Len(sDrive) = 0) And (aPath(I) = PathStart) Then
sDrive = "\" & sPath
@@ -265,27 +275,6 @@ Public Function AccnDate() As Date
End If
End Function
Public Sub ForceCorrectFileName()
Dim sAccnYear As String
Dim sAccnPoint As String
Dim sAccnDate As String
Dim oRefs As Variant
Set oRefs = MetadataFromFileName
sAccnDate = oRefs(3) & oRefs(4) & oRefs(5)
If Val(oRefs(1)) < 1900 Then
sAccnYear = Format(1900 + Val(oRefs(1)), "0000")
Else
sAccnYear = Format(Val(oRefs(1)), "0000")
End If
sAccnPoint = Format(Val(oRefs(2)), "0000")
Let sFileNameCorrected = oRefs(0) & "_" & sAccnYear & "_" & sAccnPoint & "_" & sAccnDate & oRefs(6) & ".PDF"
End Sub
Public Sub InsertIntoAccessions(Optional ByVal OnCurrent As Boolean, Optional ByVal NewRecord As Boolean, Optional ByRef ListView As Variant)
Dim sSuggestion As String
Dim rsAccnScan As DAO.Recordset
@@ -410,6 +399,27 @@ Public Sub InsertIntoAccessions(Optional ByVal OnCurrent As Boolean, Optional By
End Sub
Public Sub ForceCorrectFileName()
Dim sAccnYear As String
Dim sAccnPoint As String
Dim sAccnDate As String
Dim oRefs As Variant
Set oRefs = MetadataFromFileName
sAccnDate = oRefs(3) & oRefs(4) & oRefs(5)
If Val(oRefs(1)) < 1900 Then
sAccnYear = Format(1900 + Val(oRefs(1)), "0000")
Else
sAccnYear = Format(Val(oRefs(1)), "0000")
End If
sAccnPoint = Format(Val(oRefs(2)), "0000")
Let sFileNameCorrected = oRefs(0) & "_" & sAccnYear & "_" & sAccnPoint & "_" & sAccnDate & oRefs(6) & ".PDF"
End Sub
Public Sub ConvertFileName(ByRef Result As String)
Dim oIsOldAccnFile As New RegExp
Dim reIsCopierScan As New RegExp
@@ -501,6 +511,19 @@ Public Function isOnDefaultDrive() As Boolean
Let isOnDefaultDrive = (driveNames(1) = driveNames(2))
End Function
Public Function FolderHomePath()
Dim oFolder As cCabinetFolder
Set oFolder = New cCabinetFolder: With oFolder
.FileSourcePath = FileFolderSlug
End With
If oFolder.ID <> 0 Then
Let FolderHomePath = getDefaultDrive & oFolder.FolderPath
End If
End Function
Public Sub doCopyTo(NewPath As String)
Dim sOldFullPath As String
Dim sNewFullPath As String

0 comments on commit c20f6e5

Please sign in to comment.