• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1732
  • Last Modified:

VBA to save as zip file Run Time Error 91

'Zip and mail the ActiveWorkbook

 'This will only work if you use Outlook as your mail program
'
 'This sub will send a newly created workbook (copy of the Activeworkbook).
 'It save and zip the workbook before mailing it with a date/time stamp.
 'After the zip file is sent the zip file and the workbook will be deleted from your hard disk.
 
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")

    FileNameZip = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & ".zip"

    FileNamexls = DefPath & Left(ActiveWorkbook.Name, _
    Len(ActiveWorkbook.Name) - Len(FileExtStr)) & strDate & FileExtStr


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

        'Make copy of the activeworkbook
        ActiveWorkbook.SaveCopyAs FileNamexls

        'Create empty Zip File
         NewZip = (FileNameZip)

    'Copy the file in the compressed folder:
    'FileNameZip = name of zip file
    'filenamexls = nonzipped source file
   
    Set objShell = CreateObject("Shell.Application")
    objShell.Namespace(FileNameZip).CopyHere FileNamexls <<< BARFS HERE - RUN TIME ERROR '91'
  '  intOptions = 256

        'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until objShell.Namespace(FileNameZip).Items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0

        '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 = "ron@debruin.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
    Else
        MsgBox "FileNameZip or/and FileNameXls exist"
    End If
End Sub
0
sjkuehn
Asked:
sjkuehn
  • 13
  • 13
1 Solution
 
Robert SchuttSoftware EngineerCommented:
You've probably corrected an error on this line by adding the equals sign:
NewZip = (FileNameZip)

Open in new window

but it really needs to be the way it was:
NewZip (FileNameZip)

Open 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

Open in new window

0
 
sjkuehnAuthor Commented:
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?
0
 
Robert SchuttSoftware EngineerCommented:
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"))

Open in new window

so get rid of the loop around the wait, as a test...?
0
Cloud Class® Course: CompTIA Cloud+

The CompTIA Cloud+ Basic training course will teach you about cloud concepts and models, data storage, networking, and network infrastructure.

 
sjkuehnAuthor Commented:
Yahoo!
You wouldn't now happen to see why my zip directory gets created but the active spreadsheet isn't in there?
Thanks.
0
 
Robert SchuttSoftware EngineerCommented:
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...
0
 
Robert SchuttSoftware EngineerCommented:
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...
0
 
Robert SchuttSoftware EngineerCommented:
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?
0
 
Robert SchuttSoftware EngineerCommented:
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

Open 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.
0
 
sjkuehnAuthor Commented:
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
0
 
sjkuehnAuthor Commented:
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.
0
 
Robert SchuttSoftware EngineerCommented:
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?
0
 
sjkuehnAuthor Commented:
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.
0
 
Robert SchuttSoftware EngineerCommented:
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.
0
 
sjkuehnAuthor Commented:
"...add conditional compiling directives" - is this easy to do or should I file this issue as another open question?
thanks.
0
 
Robert SchuttSoftware EngineerCommented:
It looks easy enough:
#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

Open in new window

0
 
sjkuehnAuthor Commented:
Extremely diligent assistance and lightniing response times.
0
 
sjkuehnAuthor Commented:
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.
0
 
Robert SchuttSoftware EngineerCommented:
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 ;-)
0
 
sjkuehnAuthor Commented:
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"
0
 
Robert SchuttSoftware EngineerCommented:
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.
0
 
sjkuehnAuthor Commented:
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
0
 
sjkuehnAuthor Commented:
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.
0
 
sjkuehnAuthor Commented:
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
0
 
Robert SchuttSoftware EngineerCommented:
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.
0
 
sjkuehnAuthor Commented:
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.
0
 
Robert SchuttSoftware EngineerCommented:
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!
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

Join & Write a Comment

Featured Post

Free Tool: Site Down Detector

Helpful to verify reports of your own downtime, or to double check a downed website you are trying to access.

One of a set of tools we are providing to everyone as a way of saying thank you for being a part of the community.

  • 13
  • 13
Tackle projects and never again get stuck behind a technical roadblock.
Join Now