Try:
Private Sub Command0_Click()
Dim varFile As Variant
Dim strFileSpec As String
Dim strJpegFileLocation As String
Dim strOriginalFile As String
Dim strNewFile As String
Dim SQL As String
Dim lDateString As String
Dim lDateValue As Date
Dim strFeature As String
Dim lText1 As String
Dim lBoat As String
Dim x As Variant
Dim xPhoto As Integer
Dim xRecord As Integer
Dim fs As Object
'Dim oldPath As String, newPath As String
'
Dim FSOLibrary As Object
'Dim FSOFolder As Object
Dim folderName As String
'For Excel files with the first 2 characters of Excel sheet name are '20'
strFileSpec = "20*.xls"
'THIS LOCATION IS WHERE PHOTOS WILL BE COPIED TO AND IS AN INPUT FIELD FROM THE FORM
strJpegFileLocation = Me![PhotoDir]
'zero indexes
xPhoto = 0
xRecord = 0
' If the input in valid, then process the file search.
If Len(strFileSpec) >= 3 And InStr(strFileSpec, "*.xls") > 0 Then
ReDim FoundFiles(1 To 1)
Counter = 0
'Set the folder name to a variable
folderName = "C:\Users\Pascal\Documents" 'Me![SearchDir]
Set FSOLibrary = CreateObject("Scripting.FileSystemObject")
LoopAllSubFolders FSOLibrary.GetFolder(folderName), strFileSpec 'this line puts file names and paths into an array FoundFiles.
If Not IsEmpty(FoundFiles(1)) Then
For Each varFile In FoundFiles
'varFile
' We need to open the file and search for rows with Yes in column M
Dim rs2 As New ADODB.Recordset
Dim cnn2 As New ADODB.Connection
Dim cmd2 As New ADODB.Command
With cnn2
.Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & varFile & ";Extended Properties=Excel 8.0;"
.Open
End With
Set cmd2.ActiveConnection = cnn2
cmd2.CommandType = adCmdText
cmd2.CommandText = "SELECT * FROM [XML Metadata$]" ' We could add a Where clause here
rs2.CursorLocation = adUseClient
rs2.CursorType = adOpenStatic
rs2.LockType = adLockReadOnly
rs2.Open cmd2
While Not rs2.EOF
'...Check for fields with indicated species FROM THE FORM in column 8 and yes for import in columns 13
If rs2.Fields(7) = Me![Species] And rs2.Fields(12) = "Yes" Then
strOriginalFile = varFile
'We strip out the name of the Excel file itself
While (Right(strOriginalFile, 1) <> "") And Len(strOriginalFile) > 0
strOriginalFile = Left(strOriginalFile, Len(strOriginalFile) - 1)
Wend
' We add directory Orginal plus file name and jpg suffix
strOriginalFile = strOriginalFile & "Original" & rs2.Fields(0) & ".jpg"
' We create the location to copy to
strNewFile = strJpegFileLocation & "" & rs2.Fields(0) & ".jpg"
'Copy strOriginalFile to a new location
Set fs = CreateObject("Scripting.FileSystemObject")
fs.CopyFile strOriginalFile, strNewFile 'This file was an .xls file
Set fs = Nothing
'increment index
xPhoto = xPhoto + 1
'Convert Date field in excel file to a true date
lDateString = rs2.Fields(2)
lDateValue = CDate(lDateString)
'Convert Feature field in Excel file into Database naming protocol
If rs2.Fields(11) = "RDF" Then strFeature = "Right Dorsal Fin"
If rs2.Fields(11) = "LDF" Then strFeature = "Left Dorsal Fin"
If rs2.Fields(11) = "RCH" Then strFeature = "Right Chevron"
If rs2.Fields(11) = "RBL" Then strFeature = "Right Blaze"
If rs2.Fields(11) = "LCH" Then strFeature = "Left Chevron"
If rs2.Fields(11) = "TF" Then strFeature = "Tail Flukes"
lText1 = varFile
x = Split(lText1, "")
If Left(x(UBound(x) - 1), 4) = "Card" Then
lBoat = x(UBound(x) - 2)
Else
lBoat = x(UBound(x) - 1)
End If
' To turn warnings off
DoCmd.SetWarnings False
SQL = "INSERT INTO IDPhotosIMPORT (Project_code, Boat, Film_type, Date_of_capture, Photo_location, Frame, _
Raw_image_format, Roll, Photographer, Species, Individual_designation, Matching_designation, Photo_Comment, Feature) Values (""" & Me![ProjectCode] _
& """, """ & lBoat & """, """ & Me![FilmType] & """, #" & lDateValue & "#, """ & Me![Year] & "\photographic\thumbnail" & rs2.Fields(0) _
& ".jpg" & """, """ & Right(rs2.Fields(0), 3) & """, """ & rs2.Fields(1) & """, """ & rs2.Fields(4) & """, """ & rs2.Fields(5) _
& """, """ & rs2.Fields(7) & """, """ & rs2.Fields(9) & """, """ & rs2.Fields(10) & """, """ & rs2.Fields(13) & """, """ & strFeature & """)"
DoCmd.RunSQL SQL
'increment index
xRecord = xRecord + 1
' To turn warnings back on
DoCmd.SetWarnings True
'AFTER MANUALLY CHECKING THE DATA IN THE NEW TABLE, AND ADDING FIELDS THAT ARE CONSTANT FOR IMPORTED DATA,
'WE THEN APPEND TO THE DATABASE TABLE IDPHOTOS MANUALLY
End If
rs2.MoveNext
Wend
cnn2.Close
Next varFile
Else
MsgBox strFileSpec & " may not be a valid file specification."
Exit Sub
End If
End If
MsgBox "Import of " & xPhoto & " Photos and " & xRecord & " Records completed"
End Sub
supported by this in a standard code module:
Option Explicit
Public FoundFiles(), Counter
Sub LoopAllSubFolders(FSOFolder As Object, FileSpec)
Dim FSOSubFolder As Object
Dim FSOFile As Object
'For each subfolder call the macro
If FSOFolder.Attributes <> 1046 Then
For Each FSOSubFolder In FSOFolder.subfolders
LoopAllSubFolders FSOSubFolder, FileSpec
Next
For Each FSOFile In FSOFolder.Files
If FSOFile.Name Like FileSpec Then
Counter = Counter + 1
ReDim Preserve FoundFiles(1 To Counter)
FoundFiles(Counter) = FSOFile.Path
End If
Next
End If
End Sub
Your SQL line came up red in the VBE, you'll have to copy|paste your original SQL line.
The:
Public FoundFiles(), Counter
needs to be at the top of the code module, with or without the Option Explicit - your choice.