Public Function LogScannedDocs(SourceFolderPath As String, TargetFolderPath, frm As Form) As Long
'Files are downloaded manually from the FTP site to a folder on the server (this will be automated later)
'Validate file names
'Copy downloaded files to appropriate audit folder or to "not copied" folder if an error is found
'Add record to reference docs table to link subscriber record to actual document
'Delete all files from the common download folder
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim td As DAO.TableDef
Dim qd As DAO.QueryDef
Dim fs As Scripting.FileSystemObject
Dim folder As Scripting.folder
Dim file As Scripting.file
Dim filefolder
Dim TextArray() As String
Dim ErrCounter As Long
Dim ErrFolderName As String
Dim NewFolderName As Variant
Dim FromFileName As String
Dim strDocType As String
Dim iDupFileName As Integer
Dim iPrinted As Integer
Dim sReturnEmailBody As Variant
Dim sPathName As Variant
Dim SendEmailACK As Boolean
Dim strWhere As String
Dim sClientID As String 'TPA identifier code
Dim sCoAbbr As String 'Audit identifier code
Dim sEmpID As String 'EmpID or EmpNum '' documents all use EmpNum so doc name should also but some old docs will have EmpID so code will check both
On Error GoTo Err_Proc
Set db = CurrentDb()
iWrongClientID = 0
iWrongEmpID = 0
iWrongAuditAbbr = 0
iDupFileName = 0
iPrinted = 0
sPathName = ""
Set fs = CreateObject("Scripting.FileSystemObject")
Set folder = fs.GetFolder(SourceFolderPath)
Set filefolder = folder.Files
'recordset to log acknowledgement emails sent
Set tdLtr = db.TableDefs("tblLtrSent")
Set rsLtr = tdLtr.OpenRecordset(dbOpenDynaset, dbSeeChanges)
' Open recordset which will be used to add rows
Set td = db.TableDefs!tblRefDocs
Set rs = td.OpenRecordset(dbOpenDynaset, dbSeeChanges)
ErrFolderName = SourceFolderPath & "\Errors"
' create "error" folder if necessary
If fs.FolderExists(ErrFolderName) Then
Else
fs.CreateFolder (ErrFolderName)
End If
'clear print log
DoCmd.RunMacro "mWarningsOff"
DoCmd.RunSQL ("Delete * From tblMissingEmail;")
DoCmd.RunMacro "mWarningsOn"
ErrCounter = 0
FileCounter = 0
For Each file In filefolder
FileCounter = FileCounter + 1
TextArray = Split(file.Name, "-") 'separate parts of file name
sPathName = TextArray(1) 'save for later use in err_proc
'verify that ClientID is valid
sClientID = TextArray(0)
sCoAbbr = TextArray(1)
sEmpID = TextArray(2)
If sClientID <> Forms!frmLogin!txtClientID Then
iWrongClientID = iWrongClientID + 1
GoSub LogError
GoTo ResumeAfterError
End If
'add to reference docs table
rs.AddNew
rs!EmpID = rsMember!EmpID
rs!DocType = strDocType
rs!FullDocName = file.Name
rs!Reviewed = 0
rs!UpdatedBy = Forms!frmLogin!txtNetworkID
rs!UpdatedDT = Now()
rs!LoggedDate = Now()
rs.Update
'error 3146 resumes after rs.update so we have to avoid getting a second error
If sCoAbbr & "" = "" Then
Else
NewFolderName = DLookup("ScannedDocPath", "tblAuditParms", "CoAbbr = '" & sCoAbbr & "'")
'''''' can be removed because folder should already exist
'create folder for coabbr if necessary
If fs.FolderExists(NewFolderName) Then
Else
fs.CreateFolder (NewFolderName)
End If
FromFileName = SourceFolderPath & "\" & file.Name
If FromFileName = NewFolderName & "\" & file.Name Then 'file already added to error folder
' Debug.Print "File already exists: " & FromFileName
Else
fs.CopyFile Source:=FromFileName, Destination:=NewFolderName & "\"
End If
End If
ResumeAfterError: ' resume point for errors to let process continue
Next
On Error GoTo Err_Proc
LogScannedDocs = FileCounter
frm.txtErrCount = ErrCounter
If ErrCounter > 0 Then
frm.txtErrFolder = ErrFolderName
End If
Set rs = Nothing
Set rsMember = Nothing
On Error Resume Next
Kill SourceFolderPath & "\*.*" '''''Delete all files from Source folder
On Error GoTo 0
Exit_Proc:
frm.txtClientIDErr = iWrongClientID
frm.txtDupsErr = iDupFileName
Exit Function
LogError:
ErrCounter = ErrCounter + 1
' Debug.Print "error 3146 ---" & file.Name
FromFileName = SourceFolderPath & "\" & file.Name
fs.CopyFile Source:=FromFileName, Destination:=ErrFolderName & "\"
Return
Err_Proc:
Select Case Err.Number
Case 58 ' file already exists
Resume Next
Case 53 ' File not found
Debug.Print "error 53 ---" & file.Name
Resume Next
Case 76 ' Path not found
'add logic to determine if any documents have been processed and continue or exit depending.
If sPathName & "" = "" Then
MsgBox "The destination folder may be incorrect. The following folder was not found - " & vbCrLf & TargetFolderPath, vbOKOnly + vbCritical
Resume Exit_Proc
Else
MsgBox "The scanned path may be invalid for " & sPathName & ". The following folder was not found - " & vbCrLf & NewFolderName, vbOKOnly + vbCritical
Resume Exit_Proc
End If
Case 3022 ' Duplicate file name
iDupFileName = iDupFileName + 1
GoSub LogError
Resume ResumeAfterError
Case 3146 'Could not save; currently locked by another user.
GoSub LogError
Resume ResumeAfterError
Case 2465 'get this error when proc run from ack email because form doesn't have date fields
Resume Next
Case Else
MsgBox Err.Number & "--" & Err.Description, vbCritical
Resume Exit_Proc
Resume
End Select
End Function
Public Function fChooseDirectory()
'Declare a variable as a FileDialog object.
Dim fd As FileDialog
'Create a FileDialog object as a File Picker dialog box.
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
'Declare a variable to contain the path
'of each selected item. Even though the path is a String,
'the variable must be a Variant because For Each...Next
'routines only work with Variants and Objects.
Dim vrtSelectedItem As Variant
'Use a With...End With block to reference the FileDialog object.
With fd
'Use the Show method to display the File Picker dialog box and return the user's action.
'The user pressed the action button.
If .Show = -1 Then
'Step through each string in the FileDialogSelectedItems collection.
For Each vrtSelectedItem In .SelectedItems
'vrtSelectedItem is a String that contains the path of each selected item.
'You can use any file I/O functions that you want to work with this path.
'This example simply displays the path in a message box.
'Only one item will be returned since the file dialog is a folder picker
'MsgBox "The path is: " & vrtSelectedItem
fChooseDirectory = vrtSelectedItem
Exit Function
Next vrtSelectedItem
'The user pressed Cancel.
Else
End If
End With
'Set the object variable to Nothing.
Set fd = Nothing
fChooseDirectory = "Error - nothing chosen"
End Function
stackoverflow.com
