Below is a VBA program that will copy files listed in the "Path" field of
the "Images" table. The program works OK on my computer, running Windows XP
and Access 2002. Whether it will work OK on your computer remains to be
seen! I have tried to provide for every glitch I can think of, but you may
run into something I've not thought of. If a problem develops or if you
need further explanation of the code, I'd be happy to help.
As you are new to VBA, I have put extensive notes with the code at the
beginning of the program, where you meet things for the first time. The
lines that begin with an apostrophe are the notes. These will show up in
green in the VBA editor. The notes lines do not execute.
I tested the program by copying 88,000 files. The copying proceeded quickly
to begin with. But after a few tens of thousands of files, the program slows
down. This is unavoidable because Windows is having to do so much work
keeping track of such a large number of files in one folder. (I hope you've
got a fast computer! You'll probably need to go to lunch and have an
afternoon nap while it's running!) The solution to speeding things up would
be to get the program to bunch files in, say, groups of 10,000 files in
separate subfolders on the target drive. But you may have a good reason for
wanting all the files in one folder.
Below is an introduction to the program and a step-by-step procedure for
installing and running it. Follow the step-by-step procedure carefully. The
step-by-step procedure applies to Access 2002. You will need to adapt it if
your version of Access uses different ways of doing the same things.
INTRODUCTION
The VBA program uses two object libraries, which need to be referenced by
the database. These object libraries define programming objects, which the
program uses. The Microsoft DAO 3.6 Object Library allows the program to get
data out of the Images table. The Microsoft Scripting Runtime Object
Library allows the program to copy files on the hard disc.
STEP-BY-STEP PROCEDURE
Here's the procedure you need to follow carefully:
1. In the database window, click "Modules" to move to the VBA modules
windowpane. Click the "New" button to create a new standard module. The VBA
editor opens. Usually, the editor windowpane is on the right. Other
windowpanes may also appear, depending on whether the other windowpanes were
left open when the VBA editor was last used. For example, you may have the
Project Explorer windowpane open on the left, showing all the modules in the
database.
2. In the VBA editor, open the Tools menu and select References. The
References dialog opens. In the References dialog, scroll down and select
"Microsoft DAO 3.6" and select "Microsoft Scripting Runtime". Click OK to
close the References dialog and return to the VBA editor.
3. If either or both of the following two lines appear at the top of the
VBA editor, delete them:
Option Compare Database
Option Explicit
4. In this post, highlight the following code, copy it to the Windows
clipboard (CTRL-C), click back in the VBA editor, and paste the code
(CTRL-V) into the VBA editor windowpane. Then scroll down this post and
carry on with step 5.
Option Compare Database
Option Explicit
' Declare constant holding target path:
Private Const TARGETFOLDER As String = "K:\"
' Declare constant holding name of table:
Private Const TABLENAME As String = "Images"
' Declare constants holding the names of fields
' in the above table:
Private Const PATHFIELD As String = "Path"
Private Const FILENOTFOUNDFIELD As String = "FileNotFound"
Private Const COPIEDFIELD As String = "Copied"
' Declare object variables to be used in program:
Private mobjDB As DAO.Database
Private mobjRS As DAO.Recordset
Private mobjFSO As Scripting.FileSystemObject
' Declare other variables:
Private mstrMessage As String
Private mintButtons As VbMsgBoxStyle
Private mstrHeading As String
Private mMsgRetVal As VbMsgBoxResult
Private mCopyOneFile As VbMsgBoxResult
Private mlngRecCount As Long
Private mlngProcessed As Long
Private mlngCopied As Long
Private mlngNotFound As Long
Private mstrTargetFolder As String
Private mlngRemainder As Long
Public Sub CopyImageFiles()
' MAIN PROGRAM.
'
' This Public subprocedure calls Private subprocedures
' and functions in this module to copy files from one
' folder to another.
'
' The difference between subprocedures and functions
' is this: a called subprocedure does not a return value
' to this main subprocedure; whereas functions do. A
' function's return value can, for example, be evaluated
' by this main subprocedure to control program flow.
' This will be evident from the following.
Dim fRetVal As Boolean
' Set up error handler:
On Error GoTo CopyImageFiles_ErrorHandler
' Call the IsOK_ToStart() function and capture
' its return value in the variable "fRetVal":
fRetVal = IsOK_ToStart()
' See whether the IsOK_ToStart() function returned
' TRUE or FALSE. If FALSE, jump to the end of the
' program to stop execution:
If Not fRetVal Then GoTo Bye
' Call the CopyOneFile() function:
mCopyOneFile = CopyOneFile()
If mCopyOneFile = vbCancel Then GoTo Bye
' Call the InitialiseObjectVariables subprocedure.
' There's no return value to capture from a
' subprocedure.
Call InitialiseObjectVariables
' Call the RecordsetContainsRecords() function:
fRetVal = RecordsetContainsRecords()
' See if the function returned TRUE or FALSE.
' If FALSE, show message that there are no records
' to copy and jump to end of program:
If Not fRetVal Then
Call Message_NoRecordsToCopy
GoTo Bye
End If
' Records exist, so get record count:
Call GetRecordCount
' See if target folder exists:
fRetVal = TargetFolderExists()
If Not fRetVal Then
Call Message_TargetFolderDoesNotExist
GoTo Bye
End If
' Set counters:
mlngProcessed = 0
mlngCopied = 0
mlngNotFound = 0
' Loop through the recordset until we reach
' the end of the recordset (EOF):
Do Until mobjRS.EOF
Call CopyImageFile
' See if loop is to stop after copying one file:
If mCopyOneFile = vbYes Then Exit Do
' Move to next record in Recordset:
mobjRS.MoveNext
Loop
Call Message_Finished
Bye:
Call ClearStatusBar
Call DestroyObjectVariables
Exit Sub
CopyImageFiles_ErrorHandler:
mstrMessage = "The follow error occurred:" _
& vbNewLine & vbNewLine _
& Err.Description
mintButtons = vbOKOnly + vbExclamation
mstrHeading = "Error Number = " & Err.Number
MsgBox mstrMessage, mintButtons, mstrHeading
GoTo Bye
End Sub
Private Function IsOK_ToStart() As Boolean
' Display a message asking if it's OK to start.
'
' This function returns a Boolean (TRUE or FALSE)
' value because of "As Boolean" in above statement.
' Initialise variables for message:
mstrMessage = "Start copying files?"
mintButtons = vbYesNo + vbDefaultButton2 + vbQuestion
mstrHeading = "Program Starting"
' The next code line calls VBA's built-in MsgBox()
' function to display a message. The function uses
' information stored in above three variables.
'
' The above value of the "mintButtons" variable makes
' the MsgBox() function display only the "Yes" and "No"
' buttons. The default button is the "No" button
' because "No" is the second button. The "vbQuestion"
' built-in constant displays the Question Mark icon.
'
' Capture the MsgBox() function's return value in the
' variable GetVal:
mMsgRetVal = MsgBox(mstrMessage, mintButtons, mstrHeading)
' See if user clicked the "Yes" button by comparing
' GetVal with the VBA built-in constant "vbYes".
'
' If user clicked "Yes", the next code line sets this
' function's return value to TRUE; if the user clicked
' "No", the next code line sets this function's return
' value to FALSE:
IsOK_ToStart = (mMsgRetVal = vbYes)
End Function
Private Function CopyOneFile() As VbMsgBoxResult
' Initialise message variables:
mstrMessage = "Copy one file as a test?" _
& vbNewLine & vbNewLine _
& "Click 'Yes' to copy one file." & vbNewLine _
& "Click 'No' to copy all files." & vbNewLine _
& "Click 'Cancel' to terminate program."
mintButtons = vbYesNoCancel + vbDefaultButton1 + vbQuestion
mstrHeading = "Copy Files"
' Show message:
mMsgRetVal = MsgBox(mstrMessage, mintButtons, mstrHeading)
' Set function's return value:
CopyOneFile = mMsgRetVal
End Function
Private Sub InitialiseObjectVariables()
' Declare string variable:
Dim strSQL As String
' Create a FileSystemObject:
Set mobjFSO = New Scripting.FileSystemObject
' Point variable "mobjDB" to the current database:
Set mobjDB = CurrentDb()
' The following code line gives the "strSQL" variable
' a value. The value is an SQL SELECT statement. The
' SQL statement is used to create a Recordset object.
' The SQL statement selects all fields (represented
' by the asterisk) from the table named in the TABLENAME
' constant. Only those table records whose "Copied"
' field is FALSE will be selected. This means any files
' already copied will not be selected:
strSQL = _
"SELECT " & TABLENAME & ".*" & vbNewLine _
& "FROM " & TABLENAME & vbNewLine _
& "WHERE (((" & TABLENAME & ".Copied)=False));"
' Use the SQL statement to create a recordset object
' that allows us to edit records:
Set mobjRS = mobjDB.OpenRecordset(strSQL, dbOpenDynaset)
End Sub
Private Function RecordsetContainsRecords() As Boolean
' RETURNS:
'
' This function returns TRUE if the recordset
' contains records and FALSE if the recordset
' does not contain records.
' The BOF (beginning of file) and EOF (end of file)
' properties of the recordset are both TRUE if the
' recordset contains no records. Therefore, we can
' write the following expression to give this
' function its return value:
RecordsetContainsRecords = Not (mobjRS.BOF And mobjRS.EOF)
End Function
Private Sub Message_NoRecordsToCopy()
' Display a message saying there are no records
' in the table with the "Copied" field set to
' FALSE.
mstrMessage = "Table:" & vbTab & TABLENAME _
& vbNewLine & vbNewLine _
& "Sorry, there are no records in the above table " _
& "that need to be copied." _
& vbNewLine _
& "Either the table contains no records or the " _
& "'Copied' field for all records is set to TRUE."
mintButtons = vbOKOnly + vbInformation
mstrHeading = "Information"
MsgBox mstrMessage, mintButtons, mstrHeading
End Sub
Private Sub GetRecordCount()
' Show message in Status Bar:
Access.SysCmd acSysCmdSetStatus, "Please wait... Getting Record Count"
' Get accurate record count
' (Moving to last record in a large recordset
' may take a while!)
mobjRS.MoveLast
mlngRecCount = mobjRS.RecordCount
mobjRS.MoveFirst
End Sub
Private Function TargetFolderExists() As Boolean
' It is ESSENTIAL that the target folder exists
' before the program to proceeds and that the
' target path ends in a backslash; otherwise,
' the CopyFile method will assume the destination
' is the file name, not the folder name.
Dim strLastChar As String
' Initialise destination path,
' ensuring it ends in a backslash:
mstrTargetFolder = TARGETFOLDER
strLastChar = Right(mstrTargetFolder, 1)
If Not strLastChar = "\" Then
mstrTargetFolder = mstrTargetFolder & "\"
End If
' Set this function's return value to TRUE or FALSE:
TargetFolderExists = mobjFSO.FolderExists(mstrTargetFolder)
End Function
Private Sub Message_TargetFolderDoesNotExist()
mstrMessage = "Destination Folder: " & TARGETFOLDER _
& vbNewLine & vbNewLine _
& "The above destination folder does not exist. " _
& vbNewLine _
& "Please create the destination folder and " _
& "restart this program." _
& vbNewLine _
& "Alternatively, change the destination folder " _
& "in the program."
mintButtons = vbOKOnly + vbExclamation
mstrHeading = "Program Terminated"
MsgBox mstrMessage, mintButtons, mstrHeading
End Sub
Private Sub CopyImageFile()
' Get the PathName from the current record
' in the Recordset, see if it exists and copy it.
Dim strSourcePath As String
Dim fRetVal As Boolean
' Update status bar:
mlngProcessed = mlngProcessed + 1
Call UpdateStatusBar
' Call the GetPath() function:
strSourcePath = GetPath()
' See if the source file exists:
fRetVal = mobjFSO.FileExists(strSourcePath)
' If file does not exist, then:
' 1. Edit the current record and put TRUE in the
' "FileNotFound" field and
' 2. Exit this subprocedure to return to the loop
' in the main routine:
If fRetVal = False Then
mlngNotFound = mlngNotFound + 1
With mobjRS
.Edit
.Fields(FILENOTFOUNDFIELD) = True
.Update
End With
Exit Sub
End If
' ***************************************
' If we are here, the source file exists.
' ***************************************
' Copy source file to target folder, overwriting
' any existing file in target folder with same
' name (there shouldn't be an existing file given
' the SELECT SQL statement used earlier):
mobjFSO.CopyFile strSourcePath, mstrTargetFolder, True
' Increment counter:
mlngCopied = mlngCopied + 1
' Edit the current record, putting TRUE
' in the "Copied" field:
With mobjRS
.Edit
.Fields(COPIEDFIELD) = True
.Update
End With
' The loop will take up all of the CPU's processing
' power (unless we do something). This will result
' in the computer not responding to the keyboard or
' mouse until the loop has finished. Therefore,
' we allow Windows some time to process any CTRL-BREAK
' with the DoEvents statement.
'
' However, DoEvents will slow down the program somewhat.
' Therefore, the following code line implements DoEvents
' after every five files have been copied. You may want
' to change this number based on the size of the files
' being copied: if the files are large (so copying is
' slow), you may want to decrease the number from five;
' alternatively, if the files are small (so copying
' is fast), you may want to increase the number. The
' point is that you want Windows to respond to the
' DoEvents command within a reasonable period of time:
'
' Divide the record count by 5 and get the remainder:
mlngRemainder = mlngProcessed Mod 5
If mlngRemainder = 0 Then
DoEvents
End If
End Sub
Private Function GetPath() As String
' The field name stored in the PATHFIELD constant
' is a hyperlink field. Therefore, it may
' contain the path in different formats;
' it may contain the path:
' 1. Without a leading and trailing hash (#),
' (ie the Display Path).
' 2. With a leading and trailing hash.
' 3. With a leading "#http://" and a trailing hash.
'
' This function extracts the path from the
' PATHFIELD field for the current record in the
' recordset.
Dim strRetVal As String
Dim lngHashPos1 As Long
Dim lngHashPos2 As Long
Dim lngPathLength As Long
Dim strPathStart As String
' Get path to image from Recordset:
strRetVal = mobjRS.Fields(PATHFIELD)
' Find positions of the two hashes if they exist:
lngHashPos1 = InStr(strRetVal, "#")
lngHashPos2 = InStr(lngHashPos1 + 1, strRetVal, "#")
' If hash not found, then assume path is in
' already strRetVal:
If lngHashPos1 = 0 Then GoTo Bye
' If second hash not found, return empty string:
If lngHashPos2 = 0 Then
strRetVal = ""
GoTo Bye
End If
' Calculate characters between the two hashes:
lngPathLength = lngHashPos2 - lngHashPos1 - 1
' If path length is zero, return empty string:
If lngPathLength = 0 Then
strRetVal = ""
GoTo Bye
End If
' Get characters between the hashes:
strRetVal = Mid(strRetVal, lngHashPos1 + 1, lngPathLength)
' If path begins with
http://, then remove it:
strPathStart = LCase(Left(strRetVal, 7))
If strPathStart = "http://" Then
strRetVal = Mid(strRetVal, 8)
End If
Bye:
' Replace forward slashes with back slashes:
strRetVal = Replace(strRetVal, "/", "\")
' Set this function's return value:
GetPath = strRetVal
Exit Function
End Function
Private Sub Message_Finished()
mstrMessage = _
"Records:" & vbTab & vbTab & mlngProcessed _
& vbNewLine _
& "Files Copied:" & vbTab & mlngCopied & vbNewLine _
& "Files Not Found:" & vbTab & mlngNotFound _
& vbNewLine & vbNewLine _
& "Copying program has finished."
mintButtons = vbOKOnly + vbInformation
mstrHeading = "Program Finished"
MsgBox mstrMessage, mintButtons, mstrHeading
End Sub
Private Sub DestroyObjectVariables()
' Clean up object variables at end of program.
' Close the Recordset if it has been created.
If Not mobjRS Is Nothing Then mobjRS.Close
' Variables can be set to Nothing whether or
' not they have yet been initialised.
Set mobjRS = Nothing
Set mobjDB = Nothing
Set mobjFSO = Nothing
End Sub
Private Sub UpdateStatusBar()
Access.SysCmd acSysCmdSetStatus, "Records Processed: " _
& mlngProcessed & " of " & mlngRecCount
End Sub
Private Sub ClearStatusBar()
Access.SysCmd acSysCmdClearStatus
End Sub
5. Open the Debug menu and select the "Compile..." option. This will
compile the code. This should complete in a second without any problems. If
there's a problem, compilation will stop and the problem line will be
highlighted. You'll need to post back the details if that happens, but I
don't expect it will (because the program compiles OK on my machine).
6. Notice the program begins by declaring the following constant:
' Declare constant holding target path:
Private Const TARGETFOLDER As String = "K:\"
7. If you decide to change the destination (ie the folder where the files
are to be copied to), then you need to change what's in the quotation marks
at the end of the line. For example, you could change K:\ to M:\Images.
8. The destination drive and folder must exist or the program will stop
and alert you to the fact that the destination cannot be found.
9. There are four more constants defined at the top of the program. These
define the tablename and fieldnames as you indicated them. You can change
these constants if you change the tablename or fieldnames.
10. The main subprocedure is:
Public Sub CopyImageFiles()
11. Notice the above line begins with "Public Sub". Being a public
subprocedure means you can create a custom toolbar button in the database
window to run this subprocedure. To do this, follow these steps:
(a) In the database window, right-click any toolbar at the top to open
the shortcut menu and select "Customize". The Customize dialog opens.
(b) In the Customize dialog, click the "Toolbars" tab at the top to show
all the possible Toolbars.
(c) Click the "New" button to create a new toolbar and give the new
toolbar a name (or accept the default name).
(d) Look carefully at the screen. You will notice a new blank toolbar has
been created. On my computer, the new toolbar is just to the right, and at
the bottom, of the Customize dialog.
(e) Click the "Commands" tab at the top of the Customize dialog. The list
of Commands appears.
(f) In the Categories List on the left, select "File" (if it is not
already selected).
(g) In the Commands List on the right, select "Custom".
(h) Drag the "Custom" button and drop it on to the new blank toolbar. The
new Custom button should be surrounded with a black line, indicating that it
is selected. (If it is not selected, click it to select it.)
(i) In the "Customize" dialog, click the "Modify Selection" button (to
modify the new, selected button). A menu opens.
(j) On the menu, click in the "Name" box, delete "Custom" and enter "Copy
Image Files" (with spaces between the words).
(k) Click the "Modify Selection" button again, and, just for kicks, point
to "Change Button Image", and select the yellow smiley face icon to
distinguish your new button.
(l) Click the "Modify Selection" button again and select Properties. The
Properties sheet for the new toolbar button opens.
(m) In the Properties dialog, click in the "On Action" box and enter
"CopyImageFiles". Notice, this is the name of the subprocedure that's to be
run, which is mentioned in step 10 above. The subprocedure name does not
have any spaces, therefore, the "On Action" property must NOT have any
spaces.
(n) Click the "Close" button to close the button-properties dialog.
(o) Click the "Close" button to close the Customize dialog.
(p) Click on the Titlebar across the top of the new custom toolbar, hold
the mouse button down on the Titlebar, and drag the new toolbar to the top
of the database window, aligning the new toolbar to the right of one of the
standard toolbars.
(q) Click the "Copy Image Files" button to run the program. The "Start
Program?" dialog opens.
(r) Click the "Yes" button. The "Copy Files" dialog opens.
(r) Notice, you have three options: "Yes", "No", and "Cancel".
(s) "Yes" will copy just one file. You may want to do this as a test.
(t) "No" will copy all files. Notice, when you copy all files, a message
appears in the status bar in the bottom, left corner of the Access window,
telling you how many files have been copied so far.
(u) "Cancel" will stop the program.
(v) When you click "Yes" or "No", a message will appear when the program
finishes, telling you:
(i) how many records in the Images table were processed,
(ii) how many files were copied to the target folder, and
(iii) how many files were not found.
(w) Remember, any records in the Images table with the "Copied" field set
to TRUE, will be excluded from the copying process. This will be handy if
you stop and restart the program.
(w) You can press CTRL-BREAK to stop the program at any time. This will
leave the status bar message in place, until you start the program again or
restart Access.
I hope that's enough, and not too much, of an explanation.
Good luck. Let me know if you need anything else.
Regards
Geoff
and you want them copied to the root directory of drive (K