?
Solved

VBA to save as zip file Run Time Error 91

Posted on 2012-08-30
26
Medium Priority
?
1,682 Views
Last Modified: 2012-09-07
'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
Comment
Question by:sjkuehn
  • 13
  • 13
26 Comments
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38352364
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
 

Author Comment

by:sjkuehn
ID: 38352513
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38352552
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
What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

 

Author Comment

by:sjkuehn
ID: 38352591
Yahoo!
You wouldn't now happen to see why my zip directory gets created but the active spreadsheet isn't in there?
Thanks.
0
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38352615
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38352711
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38353666
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38354210
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
 

Author Comment

by:sjkuehn
ID: 38354396
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
 

Author Comment

by:sjkuehn
ID: 38354426
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38354506
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
 

Author Comment

by:sjkuehn
ID: 38354565
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38354656
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
 

Author Comment

by:sjkuehn
ID: 38354917
"...add conditional compiling directives" - is this easy to do or should I file this issue as another open question?
thanks.
0
 
LVL 35

Accepted Solution

by:
Robert Schutt earned 2000 total points
ID: 38354949
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
 

Author Closing Comment

by:sjkuehn
ID: 38355106
Extremely diligent assistance and lightniing response times.
0
 

Author Comment

by:sjkuehn
ID: 38355119
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38355216
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
 

Author Comment

by:sjkuehn
ID: 38369045
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38370096
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
 

Author Comment

by:sjkuehn
ID: 38370162
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
 

Author Comment

by:sjkuehn
ID: 38370325
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
 

Author Comment

by:sjkuehn
ID: 38372417
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38372746
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
 

Author Comment

by:sjkuehn
ID: 38376517
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
 
LVL 35

Expert Comment

by:Robert Schutt
ID: 38376681
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

Featured Post

Concerto's Cloud Advisory Services

Want to avoid the missteps to gaining all the benefits of the cloud? Learn more about the different assessment options from our Cloud Advisory team.

Question has a verified solution.

If you are experiencing a similar issue, please ask a related question

Windows Explorer let you handle zip folders nearly as any other folder: Copy, move, change, and delete, etc. In VBA you can also handle normal files and folders, but zip folders takes a little more - and that you'll find here.
In this post, we will learn to set up the Group Naming policy and will see how it is going to impact the Display Name and the Email addresses of the Group.
This Micro Tutorial demonstrates in Microsoft Excel how to consolidate your marketing data by creating an interactive charts using form controls. This creates cool drop-downs for viewers of your chart to choose from.
This Micro Tutorial will demonstrate how to use a scrolling table in Microsoft Excel using the INDEX function.

571 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question