Compress Worksheet File

‘error (compressed (zipped) folders error)
‘Error Warning “cannot copy a compressed file unto itself
‘oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items


Private Sub CommandButton4_Click()
Dim k As Integer
Dim strng, path, filename As String
Dim wkb As Workbook
Dim ws As Worksheet
path = "c:\docume~1\nestors\salesm~1\spread~1\masterList\"
filenameI = path & "william_Order_Form.xls"
Workbooks.Open filename:=filenameI
Application.Run "PERSONAL.XLS!mac_Automate_SetUp"
On Error Resume Next
Dim FileNameZip, FolderName
Dim strDate As String, DefPath As String
Dim oApp As Object
    DefPath = "c:\temp\salesmanMDB\will\"
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If
FolderName = "c:\temp\salesmanMDB\will\" '<< Change
FileNameZip = DefPath & "will_CustomerItemHistory" & ".zip"
    'Create empty Zip File
    NewZip (FileNameZip)
    Set oApp = CreateObject("Shell.Application")
    'Copy the files to the compressed folder
    On Error Resume Next
    'error below...
    oApp.Namespace(FileNameZip).CopyHere oApp.Namespace(FolderName).items
    On Error Resume Next
oApp.Namespace(FolderName).items.Count
    Set oApp = Nothing
End Sub
Sub NewZip(sPath)
On Error Resume Next
'Create empty Zip File
'Changed by keepITcool Dec-12-2005
    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