Copy multiple files

[losmac]

Hello,

There is only one thing to do: You must set destination
folder. The rest of things (to do) makes code.

Sub TestCopy()
CopyImages "D:\Tmp\"
End Sub

Sub CopyImages(ByVal strDestFolder As String)
Dim dbs As Database
Dim rst As Recordset
Dim strFile As String

On Error GoTo Err_CopyImages

If Right(strDestFolder, 1) <> "\" Then strDestFolder =
strDestFolder & "\"

Set dbs = CurrentDb
'open query with images names and paths
Set rst = dbs.OpenRecordset("Images")
'loop through all records
With rst
Do While Not .EOF
strFile = Nz(.Fields("FilePathAndName"), "") 'get
a file path & name
If strFile <> "" Then
'copy file from source folder to destanation
folder
MsgBox "Source:" & vbCr & strFile & vbCr &
vbCr & _
"Destanation:" & vbCr & strDestFolder &
ExtractFileNameOrFolder(strFile, , 2), vbInformation, "Now
copying..."
'FileCopy strFile, strDestFolder &
ExtractFileNameOrFolder(strFile, , 2)
End If
.MoveNext
Loop
End With

End_CopyImages:
On Error Resume Next
rst.Close
dbs.Close
Set rst = Nothing
Set dbs = Nothing

Exit Sub

Err_CopyImages:
MsgBox "Error description: " & vbCr & _
Err.Description, vbExclamation, "Error
number: " & Err.Number
Err.Clear
GoTo End_CopyImages
End Sub


Function ExtractFileNameOrFolder(strToSrch As String,
Optional strToFnd As String = "\", Optional metoda As Long
= 0) As String
Dim i As Long, dl As Long, poz As Long

dl = Len(strToSrch)

poz = InStr(poz + 1, strToSrch, strToFnd)
Do While poz <> 0
i = poz
poz = InStr(poz + 1, strToSrch, strToFnd)
Loop

Select Case metoda
Case 0 'path, for example: C:\path\
ExtractFileNameOrFolder = Left(strToSrch, i)
Case 1 'file name without extension, for example:
fileName
dl = dl - i - 4
ExtractFileNameOrFolder = Mid(strToSrch, i + 1, dl)
Case 2 'file name with extension, for example:
fileName.xls
dl = dl - i
ExtractFileNameOrFolder = Mid(strToSrch, i + 1, dl)
End Select

End Function

If You want, You can add ProgressBar to your form

Have a nice day and fun programming!