PDA

View Full Version : Archiving Files - Create New Folders and Archive



youngmcc
05-17-2011, 08:57 AM
Hi,

Im wondering if anyone can help.

I have a shared server that a large number of XML files are sent to on a daily basis. I run a process at the end of each day to summarise these files, however, as part of this process I would also like to archive them based on their date.

The server path is I:\Messages\

The filename is made up of the below:

I have highlighted the date part in red. The remainder of the filename to the right of the red is a timestamp and then counter.

Brian_Example_20110516155242_000024

What I would like to do is archive these files based on Year and then Month.

So for example the above file would have the folder 2011 created if it does not already exist and then create the folder 05 - May if that does not already exist. The file would then be moved to this folder.

So the final filepath would become:

I:\2011\05 - May\Brian_Example_20110516155242_000024.xml

Year folders made up in format YYYY and Month Folders made up of the month number "-" and Month Name. 05 - May for this month.

Thanks in advance.

McC

Kenneth Hobs
05-17-2011, 08:20 PM
Sub MoveXMLFiles()
Dim serverPath As String, a() As String, fName As String, xName As String
Dim fso As Object
serverPath = "I:\Messages\"
'serverPath = "c:\t\test\"
If Dir(serverPath, vbDirectory) = "" Then
MsgBox serverPath & " does not exist!", vbCritical, "Macro Ending"
Exit Sub
End If
Set fso = CreateObject("Scripting.FileSystemObject")
'If fso.GetFolder(serverPath).Files.Count = 0 Then Exit Sub

fName = fso.getbasename(Dir(serverPath & "*.xml"))
Do
a() = Split(fName, "_")
If UBound(a) = 3 Then
xName = Left(serverPath, 3) & Left(a(2), 4) & "\" & Mid(a(2), 5, 2) & " - " & _
Format(DateSerial(2000, Mid(a(2), 5, 2), 1), "mmm") & "\"
If Dir(xName, vbDirectory) = "" Then Shell ("cmd /c md " & """" & xName & """")
On Error Resume Next 'errors if file exists in target path
Name serverPath & fName & ".xml" As xName & fName & ".xml"
End If
fName = Dir
fName = fso.getbasename(fName)
Loop Until fName = ""

Set fso = Nothing
End Sub