Define current Sub folder within code (1 Viewer)

jbretel

New member
Local time
Today, 12:16
Joined
Oct 8, 2014
Messages
3
Hi All,

Before I ask the question I must say that the below code ACTUALLY WORKS ! - BUT I have a problem with defining a folder pathway....

Here's the question:-

I am trying to define a path to identify a current folder - I'll try and explain the way the following code works first (and it does work 100%)

The following code identifies folders and sub-folder structures and imports them (their structures and folder paths and filenames) into a DB

It also simultaneously retrieve's any xml docs within those respective folders and imports the XML data into the same database ........ and then moves those folders into a "processing folder" location.

Cool yes, but I can only import the XML doc's at the moment, by hard coding the path (like this):-

path = "C:\Users\jeremyb\Desktop\snapmad\XYZ123\XYZFILES\0061940\"

The code is highlighted as above - in the FULL code below:

I'm hoping someone can point out what is probably very obvious to the more experienced amongst all of you..... :)

Many thanks in advance,

Jeremy

///////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////////
Code Begins:-



Option Compare Database
Option Explicit

Dim db As Database
Dim rst As Recordset
Dim files As Long


Sub listfiles(root As String)

Dim fname As String
Dim Fso As Object, Fldr As Object, SubFldr As Object, F As Object

If Right(root, 1) <> "\" Then root = root & "\" 'just in case there is no trailing \

Set Fso = CreateObject("scripting.filesystemobject")
Set Fldr = Fso.GetFolder(root) 'use this current folder

'now iterate the files - error handler just in case
On Error GoTo failFILE
For Each F In Fldr.files
'append any file to the table
rst.AddNew
rst!folder = root
rst!filename = F.Name
rst!order_number = Fldr.Name
rst.Update
files = files + 1
nextfile:
Next

'now iterate the folders - error handler just in case
On Error GoTo failFOLDER
For Each SubFldr In Fldr.SubFolders
listfiles (root & SubFldr.Name)

' ***** Beg of JEB added to import XML file into DB
Dim strFile As String 'Filename
Dim strFileList() As String 'File Array
Dim intFile As Integer 'File Number
Dim filename As String
Dim path As String
DoCmd.SetWarnings False
'path = (root)
path = "C:\Users\jeremyb\Desktop\snapmad\XYZ123\XYZFILES\0061940\"
'Loop through the folder & build file list
strFile = Dir(path & "*.xml")
While strFile <> ""
'add files to the list
intFile = intFile + 1
ReDim Preserve strFileList(1 To intFile)
strFileList(intFile) = strFile
strFile = Dir()
Wend
'see if any files were found
If intFile = 0 Then
MsgBox "No files found"
Exit Sub
End If
'cycle through the list of files
For intFile = 1 To UBound(strFileList)
filename = path & strFileList(intFile)
Application.ImportXML filename, acAppendData
Next intFile
DoCmd.SetWarnings True
' ***** Eof JEB added to import XML file into DB


' ***** Beg of JEB inserted to move current SubFldr to the Archive Folder after importing file structure & XML file details into DB "
Dim filesys
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FolderExists(SubFldr) Then
filesys.MoveFolder SubFldr, "C:\\Users\jeremyb\Desktop\snapmad\XYZ123\XYZFILES\0061940\ - Processing\"
End If
' ***** End of JEB inserted to move current SubFldr to the Archive Folder after importing file structure & XML file details into DB "

nextfolder:
Next

Exit Sub

failFILE:
MsgBox ("Unable to examine file in folder " & root & vbCrLf & _
"Error: " & Err & " Desc: " & Err.Description)
Exit Sub
Resume nextfile

failFOLDER:
MsgBox ("Unable to examine folder " & root & vbCrLf & _
"Error: " & Err & " Desc: " & Err.Description)
'
'Note I aborted here with exit sub, rather than continue the loop -
'when I tried it, I got a problem trying to continue the loop,
'with the fso loop dropping out of scope.
Exit Sub

Resume nextfolder

End Sub

Private Sub Command0_Click()
Set db = CurrentDb
Set rst = db.OpenRecordset("tblFiles", dbOpenDynaset)
files = 0

'listfiles ("C:\Users\Jon\Desktop\")
listfiles ("C:\Users\jeremyb\Desktop\snapmad\XYZ123\XYZFILES\0061940\")

rst.Close
Set rst = Nothing
Set db = Nothing

MsgBox ("Finished: " & files & " files found. ")
End Sub
 
Last edited:

MarkK

bit cruncher
Local time
Today, 05:16
Joined
Mar 17, 2004
Messages
8,178
You never asked a question. Do you want help with something?
 

jbretel

New member
Local time
Today, 12:16
Joined
Oct 8, 2014
Messages
3
You never asked a question. Do you want help with something?


Sorry - I want to replace the path = code from the following (which is an absolute path reference and not a dynamically generated path from within the string code):-

path = "C:\Users\jeremyb\Desktop\snapmad\XYZ123\XYZFILES\006 1940\"

with the correct code to return the "folder" the code is actually working in -

ie path = SubFldr

You can see the code is spooling through each folder and performing firstly the recording of the file structure (folder name and underlying file names) into a table in the DB, and then importing the XML file (with the full pathway defined - which is good for the one location only - not any subsequent folders) and then finally checking and moving the folder & files to a new location.

This all happens within one string of the code search (before it moves on to the next Subfolder in the root (defined as FTP Folder)

So what code do I need to call the path for the current folder the code is doing all the business in?

Hope that's a little bit clearer


Thx JB
 

Users who are viewing this thread

Top Bottom