Copy some pdf files to another folder (1 Viewer)

follower2020

New member
Local time
Today, 20:57
Joined
May 14, 2020
Messages
9
Hello

we have a record for each patient
each patient will have patient number

my co workers prepare the documents needed , get them signed and then they scan in order to email them

when they scan , they name each file this way : the patient number then some description


e.g.1255 GOP
1255 Passport copy
etc

i want a code to copy all pdf files starting with e.g. 1255 to another folder
( i create a folder for each patient with the patient number as the folder name )

is this possible in access.

so i want access to copy all pdf files starting with the patient number ( i.e. the current record ) to a folder

e.g. copy all pdf files starting with 1255 to the folder "C:\"Patients\1255\"
source folder="C:\Users\mhm\Desktop\Sourcefolder"
destinationfolder= "C:\"Patients\" & me.patientnumber
Thank you
 
Haven't you asked this before?
 
usage:
vSrcDir = "C:\Users\mhm\Desktop\Sourcefolder\"
vTargDir = "C:\Patients\"
vNum = Me.patientnumber

CopyFiles2Dir vSrcDir, vTargDir , vNum



Code:
Public Sub CopyFiles2Dir(ByVal pvSrcDir, ByVal pvTargDir, ByVal pvNum)

Dim fs As Object
Dim Folder As Object
Dim oFile As Object
Dim vName, vTargFile
  
pvSrcDir = FixDir(pvSrcDir) 'make sure it has slash

pvTargDir = FixDir(pvTargDir) & pvNum
MakeDir pvTargDir
pvTargDir = FixDir(pvTargDir)

Set fs = CreateObject("Scripting.FileSystemObject")
Set Folder = fs.GetFolder(pvSrcDir)

For Each oFile In Folder.Files
  
    If InStr(oFile.Name, pvNum) = 1 Then    'or put your file type here
       vName = oFile.Name
       vTargFile = pvTargDir & vName
     
         'copy file
       Copy1File oFile, vTargFile
       
          'move the file
       'Name oFile As vTargFile
    End If
  
skip1:
Next

Set oFile = Nothing
Set Folder = Nothing
Set fs = Nothing
End Function


Public Function Copy1File(ByVal pvSrc, ByVal pvTarg) As Boolean
Dim fso
On Error GoTo errMake

Set fso = CreateObject("Scripting.FileSystemObject")    '(reference: ms Scripting Runtime)
fso.CopyFile pvSrc, pvTarg
Copy1File = True
Set fso = Nothing
Exit Function

errMake:
'MsgBox Err.Description & vbCrLf & pvSrc, , "Copy1File(): " & Err
Set fso = Nothing
End Function


'check dir path has a backslash at the end for attaching more files or dirs to it
Public Function FixDir(pvPath)
If pvPath = "" Then Exit Function
If Right(pvPath, 1) <> "\" Then pvPath = pvPath & "\"
FixDir = pvPath
End Function
 
Last edited:

Users who are viewing this thread

Back
Top Bottom