mdmackillop
07-16-2009, 06:27 AM
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)
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
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