Solved: Create folder structure

[mdmackillop]

The following code is used to create a copy of an existing folder structure, delete the files within it, and make a modified copy of the original files to the new structure.Is there a better way to create the folder structure, without copying the files? (there can be a few hundred files involved)
[vba]
Option Explicit

Dim i As Long

Sub CopyFolder()
Dim fs, f, f1, s, sf
Dim Pth As String, Small As String
Pth = "P:\1000 PRI"
Small = Left(Pth, 7) & "s" & Right(Pth, Len(Pth) - 7)
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
MkDir Small
On Error GoTo 0
fs.CopyFolder Pth, Small
KillFiles Pth, Small
End Sub

Sub KillFiles(Pth, folderspec)
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(folderspec)
Set sf = f.SubFolders
On Error Resume Next
For Each f1 In sf
Kill folderspec & "\" & f1.Name & "\*.*"
ResizeFiles Pth & "\" & f1.Name
KillFiles Pth & "\" & f1.Name, folderspec & "\" & f1.Name
Next
End Sub

Sub ResizeFiles(Pth As String)
Dim ShellComm As String
Dim Dest As String
Dim fil
If Len(Dir(Pth & "\*.jpg")) > 0 Then
Dest = Left(Pth, 7) & "s" & Right(Pth, Len(Pth) - 7)
ShellComm = "C:\Program Files\IrfanView\i_view32.exe " & Pth & "\*.jpg _
/resize=(800,602) /aspectratio /resample /convert=" & Dest & "\*.jpg"
Shell (ShellComm)
End If
End Sub
[/vba]

[Bob Phillips]

Malcolm,

Couldn't you use the FSO MoveFolder method to effectively rename the folders?

[mdmackillop]

Hi Bob,
It's not a case of moving the folders. I should end up with two folder stuctures differing only in that the top level name is modified from 1234 Test to 1234s Test.
I created some code to extract folder names into a collection, and then create the structure, but it was very messy looking at every file and as you can't create Top/Middle/Bottom/Detail in one MkDir command.

[Bob Phillips]

I thought you were renaming it.

So how about fs.CopyFolder?

[mdmackillop]

I think I got it. Make a folder instead of killing the contents!
[VBA]
Option Explicit

Dim i As Long

Sub CopyFolder()
Dim fs, f, f1, s, sf
Dim Pth As String, Small As String
Pth = ActiveCell.Value
Small = Left(Pth, 7) & "s" & Right(Pth, Len(Pth) - 7)
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
MkDir Small
On Error GoTo 0
MakeFolders Pth, Small
End Sub

Sub MakeFolders(Pth, folderspec)
Dim fs, f, f1, s, sf
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(Pth)
Set sf = f.SubFolders
On Error Resume Next
For Each f1 In sf
MkDir folderspec & "\" & f1.Name
ResizeFiles Pth & "\" & f1.Name
MakeFolders Pth & "\" & f1.Name, folderspec & "\" & f1.Name
Next
End Sub

Sub ResizeFiles(Pth As String)
Dim ShellComm As String
Dim Dest As String
Dim fil
If Len(Dir(Pth & "\*.jpg")) > 0 Then
Dest = Left(Pth, 7) & "s" & Right(Pth, Len(Pth) - 7)
ShellComm = "C:\Program Files\IrfanView\i_view32.exe " & Pth & "\*.jpg /resize=(800,602) /aspectratio /resample /convert=" & Dest & "\*.jpg"
Shell (ShellComm)
End If
End Sub

[/VBA]