slamet Harto
04-18-2008, 05:08 AM
Hallo there,
I have the following macro for Zip all files in a folder, but it seems does not work as my expectation. What I need is macro will zip / create rar files in other folder.
For example:
in "C:\A\" there are 5 files that needs to create a zip/rar file
When we run a macro then this zip/rar file move to "C:\B\" and delete all excel files in "C:\A"
I would appreciate your kind suggestion on this.
Warm rgds,
Harto
Sorry, this code just a copy for sample only.
Sub Zip_ActiveWorkbook( )
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
DefPath = ThisWorkbook. Path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameZip = DefPath & Left(ActiveWorkbook .Name, Len(ActiveWorkbook. Name) - 4) & ".zip"
FileNameXls = DefPath & ActiveWorkbook. Name
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace( FileNameZip) .CopyHere FileNameXls
On Error Resume Next
Do Until oApp.NameSpace (FileNameZip) .items.Count = 1
Application. Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "Your Backup is saved here: " & FileNameZip
End Sub
Sub NewZip(sPath)
If Len(Dir(sPath) ) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub
I have the following macro for Zip all files in a folder, but it seems does not work as my expectation. What I need is macro will zip / create rar files in other folder.
For example:
in "C:\A\" there are 5 files that needs to create a zip/rar file
When we run a macro then this zip/rar file move to "C:\B\" and delete all excel files in "C:\A"
I would appreciate your kind suggestion on this.
Warm rgds,
Harto
Sorry, this code just a copy for sample only.
Sub Zip_ActiveWorkbook( )
Dim strDate As String, DefPath As String
Dim FileNameZip, FileNameXls
Dim oApp As Object
DefPath = ThisWorkbook. Path
If Right(DefPath, 1) <> "\" Then
DefPath = DefPath & "\"
End If
FileNameZip = DefPath & Left(ActiveWorkbook .Name, Len(ActiveWorkbook. Name) - 4) & ".zip"
FileNameXls = DefPath & ActiveWorkbook. Name
NewZip (FileNameZip)
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace( FileNameZip) .CopyHere FileNameXls
On Error Resume Next
Do Until oApp.NameSpace (FileNameZip) .items.Count = 1
Application. Wait (Now + TimeValue("0:00:01"))
Loop
On Error GoTo 0
MsgBox "Your Backup is saved here: " & FileNameZip
End Sub
Sub NewZip(sPath)
If Len(Dir(sPath) ) > 0 Then Kill sPath
Open sPath For Output As #1
Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
Close #1
End Sub