VBA to save as zip file Run Time Error 91

You've probably corrected an error on this line by adding the equals sign:

NewZip = (FileNameZip)

Select allOpen in new window

but it really needs to be the way it was:

NewZip (FileNameZip)

Select allOpen in new window

and copy the sub from Ron's page:

Sub NewZip(sPath)
'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

Select allOpen in new window

thanks so far. I am encouraged! NewZip subroutine is creating the test.zip. The test.xlsm file isn't being compressed into the test.zip, though. Easy fix?

No, it should work but I haven't tested it now. I think the last time I copied it from somewhere else in vbs form. The thing is, there was a Sleep in there that was supposedly required but I replaced it with a loop checking for file size. I tested that just now but strangely it only works with small files. It seems that the zipping action is killed if the script terminates or tries to access the zip file (what the excel version does). A temporary fix might be to replace the "Keep script waiting" part by a single wait that's long enough for any file you expect to be compressed, maybe:

Application.Wait (Now + TimeValue("0:00:10"))

Select allOpen in new window

so get rid of the loop around the wait, as a test...?

Yahoo!
You wouldn't now happen to see why my zip directory gets created but the active spreadsheet isn't in there?
Thanks.

I'm guessing from the "Yahoo!" that you see the mail on your screen, unfortunately that is not a sign that we're getting there :-(

Actually I can't get it to work myself now, I found a slightly different implementation here: http://excelexperts.com/Zip-Files-from-Excel
But it doesn't matter, it won't add the file to the zip. I do find an interesting difference with the old vbs script I have: when that crashes, it leaves an 'empty' zip file of 22 bytes which is consistent with the function that writes 4 'magic' bytes and 18 zeroes, I can go in to that zip and find no files but it is a valid zip file it seems. From the VBA code however, a file of 24 bytes is left behind which is not a valid zip file and it's caused by a CR/LF added to the end of the file. Investigating now...

Well I've got the valid (22 byte) file now (code from ozgrid) but still no excel file in the zip. From the old vbs I found a number of files in my temp directory that contain partially zipped files. So definitely there's some problem with the script being killed during the zip but I'm afraid I'm gonna have to call it a day. Hope to be able to help further but might need to switch to something else, first thing that comes to mind is an external tool...

Still no luck I'm afraid, I'm wondering what happened because this code used to work as evidenced by all the people using it and excited by finding those examples (until a few years ago...). I'm thinking now that Win7 does this differently. Giving it some thought now if I can find/think of something like calling the system dll's directly or similar approach.

Have you thought about the possibility of calling winzip or 7zip for example or is calling an external program out of the question completely?

This is incredible (to me at least) but after trying all sorts of code from other sites, waiting for the number of files in the zip or whatever, I went back to basic and found this works:

Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

Sub ZipVbs(ZipFile, InputFile)
    CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
    Dim objShell
    Set objShell = CreateObject("Shell.Application")
    objShell.Namespace(ZipFile).CopyHere (InputFile)

    'Required!
    Sleep 2000
End Sub

Sub Zip_Mail_ActiveWorkbook()
    Dim strDate As String, DefPath As String, strbody As String
    Dim objShell As Object
    Dim OutApp As Object, OutMail As Object
    Dim FileNameZip, FileNamexls As String
    Dim objSource As Object
    Dim objTarget
    Dim FileExtStr As String

    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
    
    Dim FileBasename As String
    FileBasename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate
    FileNameZip = DefPath & FileBasename & ".zip"
    FileNamexls = DefPath & FileBasename & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNamexls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNamexls

        'Copy the file in the compressed folder:
        'FileNameZip = name of zip file
        'filenamexls = nonzipped source file
        ZipVbs FileNameZip, FileNamexls

        'Create the mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        strbody = "Hi there" & vbNewLine & vbNewLine & _
                  "This is line 1" & vbNewLine & _
                  "This is line 2" & vbNewLine & _
                  "This is line 3" & vbNewLine & _
                  "This is line 4"

        'On Error Resume Next
        With OutMail
            .To = "xxx@xxx.nl"
            .CC = ""
            .BCC = ""
            .Subject = "This is the Subject line"
            .Body = strbody
            .Attachments.Add FileNameZip
            .Display   'or use .Send
        End With
        On Error GoTo 0

        'Delete the temporary Excel file and Zip file you send
        'Kill FileNameZip
        'Kill FileNamexls
        Set objShell = Nothing
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"
    End If
End Sub

Select allOpen in new window

Note that I commented out the deletion of the temp files to be able to check the results but that could be put back in. Otherwise the slightest changes like not using parentheses on copy or changing the Sleep especially can cause it to stop working again...

EDIT: oops, deleted my email address from the code.

Hi - I'm not getting your decalaration line to "compile" (shows as red text in my VBA editor)


Option Explicit

Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)  <<<<COMPILE ERROR, red text)


Sub ZipVbs(ZipFile, InputFile)
    CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
    Dim objShell
    Set objShell = CreateObject("Shell.Application")
    objShell.Namespace(ZipFile).CopyHere (InputFile)

    'Required!
    Sleep 2000
End Sub

I see by your time stamp you responded at 3:29am. I hope you are in a different time zone! Thanks again for your quick turns on these issues.

Hehe, I'm on CET (in The Netherlands). One of my responses was quite late last night (more like early this morning), sometimes a problem can really bug me. No use trying to get to sleep in my bed at that point, keep going until I solve it or fall asleep at the keyboard ;-)

The code needs to be in a Module, not Sheet or ThisWorkbook. Could that be why it's not compiling?

Yes, it added your stuff in the module.

I just read the error msg box:
Compile Error:
The code in this project must be updated for use on 64-bit systems. Please review and update
Declare statements and then mark them with PTRSafe attribute.

Hmm, I'm running this on a 64 bit system (but 32 bit Excel and did originally create the xls on an older version and 32 bit computer).

Searching the net for that message tells me you can add conditional compiling directives, but I must admit I have never seen this before in VBA.

"...add conditional compiling directives" - is this easy to do or should I file this issue as another open question?
thanks.

Extremely diligent assistance and lightniing response times.

Robert - Triple Yahoo!!!
I had to comment out these as they would not compile, but the additional lines made the whole thing work.
'#Else
'    Private Declare Sub Sleep Lib "kernel32" (ByVal ms as Long)

I am not sure what you get for your success but please accept my salutations.
Steve K.

Great!

There's a number of different rewards but more important for me is learning from it myself and try having a bit of fun while doing it. If that costs me the occasional sleepless night, so be it ;-)

Robert - I could use your help answering this expert's exchange question as well. I am not good at writing code and just need someone to track through this. I hope you can tackle it. This may be the question ID:
 012-09-05 at 09:26:22 ID27854252

the Topic heading is "Supposed to create a zip file from Excel workbook and attach it to an email"

Found it, I'll have a better look later but I don't think I'll get to it today, first thought is some changes you made don't make sense to me like ".Save" on the zip file object/name variable? Maybe try to go back to what works and add in changes in small bits to see when it stops working.

Awesome. It should be simple but I am not encouraged by the complications I am experiencing. Thanks.

Here's the version I am trying to edit now:

Option Explicit
#If VBA7 Then
    Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal ms As LongPtr)
'#Else
'    Private Declare Sub Sleep Lib "kernel32" (ByVal ms as Long)
#End If

    Public TempFilePath As String
    Public TempFileName As String
    Public OutApp As Object
    Public OutMail As Object
    Public FileExtStr As String
    Public FileFormatNum As Long
    Public Sourcewb As Workbook
    Public destwb As Workbook
    Public wks As Worksheet
    Public ResMgrName As Range
    Public ResMgrEmail As Range
    Public OpsName As Range
    Public OpsEmail As Range
    Public SuperName As Range
    Public SuperEmail As Range
    Public CRAName As Range
    Public CRAEmail As Range
    Public RateMgrName As Range
    Public RateMgrEmail As Range
    Public ProgMgrName As Range
    Public ProgMgrEmail As Range
    Public DirName As Range
    Public DirEmail As Range
    Public Agency As Variant
    Public Sender As Variant
    Public IsBodyHtml As Boolean


Sub ZipVbs(ZipFile, InputFile)
    CreateObject("Scripting.FileSystemObject").CreateTextFile(ZipFile, True).Write "PK" & Chr(5) & Chr(6) & String(18, vbNullChar)
    Dim objShell
    Set objShell = CreateObject("Shell.Application")
    objShell.Namespace(ZipFile).CopyHere (InputFile)

    'Required!
    Sleep 2000
End Sub

Sub Zip_Mail_ActiveWorkbook()

    Dim strDate As String, DefPath As String, strbody As String
    Dim objShell As Object
    Dim OutApp As Object, OutMail As Object
    Dim FileNameZip, FileNamexls As String
    Dim objSource As Object
    Dim objTarget
    Dim FileExtStr As String
   
    Name_Email_Ranges
   
    DefPath = Application.DefaultFilePath
    If Right(DefPath, 1) <> "\" Then
        DefPath = DefPath & "\"
    End If

    'Create date/time string and the temporary xl* and zip file name
    If Val(Application.Version) < 12 Then
        FileExtStr = ".xls"
    Else
        Select Case ActiveWorkbook.FileFormat
        Case 51: FileExtStr = ".xlsx"
        Case 52: FileExtStr = ".xlsm"
        Case 56: FileExtStr = ".xls"
        Case 50: FileExtStr = ".xlsb"
        Case Else: FileExtStr = "notknown"
        End Select
        If FileExtStr = "notknown" Then
            MsgBox "Sorry unknown file format"
            Exit Sub
        End If
    End If

    strDate = Format(Now, " yyyy-mm-dd h-mm-ss")
   
    Dim FileBasename As String
    FileBasename = Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate
    FileNameZip = DefPath & FileBasename & ".zip"
    FileNamexls = DefPath & FileBasename & FileExtStr

    If Dir(FileNameZip) = "" And Dir(FileNamexls) = "" Then

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNamexls

        'Copy the file in the compressed folder:
        'FileNameZip = name of zip file
        'filenamexls = nonzipped source file
        ZipVbs FileNameZip, FileNamexls

        'Create the mail
        Set OutApp = CreateObject("Outlook.Application")
        Set OutMail = OutApp.CreateItem(0)
        strbody = "To: " & vbNewLine & vbNewLine & _
                  "Please open the attached file which is" & vbNewLine & _
                  "the rate revision worksheet for ." & vbNewLine & _
                  "Review it and forward it or return it as appropriate. Thanks"
'" & Agency & "& SuperName

        'On Error Resume Next
        With OutMail
            .To = SuperEmail.Text
            .CC = ResMgrEmail.Text
            .BCC = ""
            .Subject = "the rate revision worksheet for " & Agency & "."
            .Body = strbody
            .Attachments.Add FileNameZip
            .Display   'or use .Send
        End With
        On Error GoTo 0

        'Delete the temporary Excel file and Zip file you send
        'Kill FileNameZip
        'Kill FileNamexls
        Set objShell = Nothing
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"
    End If
End Sub

Robert - hold off on spending any time on this - I just got 95% of it to work so I  may be able to finish it. thanks for being available.

Yahoo, the zip file is being created and attached! For some reason I am having trouble with the email  variables for  ResMgrEmailText or AgencyRange. do you see anything obvious?

Be sure you reply through the other question thread so i can give you the points.



    Public SuperText As String
    Public AgencyText As String
    Public AgencyRange As Range

            With OutMail
            .To = SuperText
            .CC = ResMgrEmailText
            .Subject = "the rate revision worksheet for " & AgencyRange & "."
            .Body = strbody
            .Attachments.Add FileNameZip
            .Display   'or use .Send




Sub Name_Email_Ranges()  '>>>>>>>>>>>>>>this works for other variables
       
    Set wks = Worksheets("Rate Change Wksht")
    Set SuperName = wks.Range("r3")
    Set SuperEmail = wks.Range("s3")
     Set AgencyRange = wks.Range("c11")
   
'    Set Agency = Mid("=INDEX('Retrieve Rates Data '!$B$1:$B$315,'Rate Change Wksht'!D3+1)", 6, 25)
     ResMgrEmailText = Mid(ResMgrEmail.Text, 1, 6)
     SuperText = Mid(SuperEmail.Text, 1, 6)
     AgencyText = Mid(AgencyRange.Text, 6, 25)
   
End Sub

I don't see anything obvious but there's not much to go on because the definition of the variables depends on what's in the form fields.

I think it would be fair if you can post your latest code with some more info on the other question thread and give the good people there a chance to help you out as well. I'll keep monitoring there as well of course, I may have a new insight and then I won't hesitate to post.

Hope you can agree with that,
Robert.

good thinking. Actually I withdrew the question as it is all fixed. I followed the trail of definitions and assumed some things about the type of fields that would work as email destinations (strings). I have never been trained in this stuff so I don't know simple things sometimes.

I got several responses from the same person but they were off the mark. Thanks for your help. I would appreciate being able to notify you if i post a question since you know my limited skill level.

Great! No problem, I recently changed my 'policy' and keep monitoring questions I participated in. And also you can reach me through my website which you can find in my profile. Talk to you later!