Question

我想使用Outlook通过电子邮件发送工作簿的压缩副本。如何扩展下面的宏，以便它附加一个压缩的工作簿？

Sub EmailWorkbook()

Dim OL As Object, EmailItem As Object
Dim Wb As Workbook

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Wb = ActiveWorkbook
Wb.Save
With EmailItem
    .Subject = "COB" & Format(Range("yesterday"), "ddMMMyy")
    '.Body = ""
    .To = "somewhere@maildomain.com"
    '.Cc = ""
    '.Bcc = ""
    .Importance = olImportanceNormal
    .Attachments.Add Wb.FullName
    .Display
End With

Application.ScreenUpdating = True

Set Wb = Nothing
Set OL = Nothing

End Sub

Answer 1

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


Function bIsBookOpen(ByRef szBookName As String) As Boolean
' Rob Bovey
    On Error Resume Next
    bIsBookOpen = Not (Application.Workbooks(szBookName) Is Nothing)
End Function


Function Split97(sStr As Variant, sdelim As String) As Variant
'Tom Ogilvy
    Split97 = Evaluate("{""" & _
                       Application.Substitute(sStr, sdelim, """,""") & """}")
End Function


Sub Zip_File_Or_Files()
    Dim strDate As String, DefPath As String, sFName As String
    Dim oApp As Object, iCtr As Long, I As Integer
    Dim FName, vArr, FileNameZip

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

    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & "MyFilesZip " & strDate & ".zip"

    'Browse to the file(s), use the Ctrl key to select more files
    FName = Application.GetOpenFilename(filefilter:="Excel Files (*.xl*), *.xl*", _
                    MultiSelect:=True, Title:="Select the files you want to zip")
    If IsArray(FName) = False Then
        'do nothing
    Else
        'Create empty Zip File
        NewZip (FileNameZip)
        Set oApp = CreateObject("Shell.Application")
        I = 0
        For iCtr = LBound(FName) To UBound(FName)
            vArr = Split97(FName(iCtr), "\")
            sFName = vArr(UBound(vArr))
            If bIsBookOpen(sFName) Then
                MsgBox "You can't zip a file that is open!" & vbLf & _
                       "Please close it and try again: " & FName(iCtr)
            Else
                'Copy the file to the compressed folder
                I = I + 1
                oApp.Namespace(FileNameZip).CopyHere FName(iCtr)

                'Keep script waiting until Compressing is done
                On Error Resume Next
                Do Until oApp.Namespace(FileNameZip).items.Count = I
                    Application.Wait (Now + TimeValue("0:00:01"))
                Loop
                On Error GoTo 0
            End If
        Next iCtr

        MsgBox "You find the zipfile here: " & FileNameZip
    End If
End Sub

Answer 2

下载并安装7-Zip，然后按如下所示修改您的现有代码：

Sub EmailWorkbook()
    Dim OL As Object, EmailItem As Object
    Dim xlWbName As String, xlWbPath As String, ext As String

    'Set xlWb file name and path
    xlWbName = "ENTER FILE NAME HERE"
    xlWbPath = "C:\ENTER\FILE\FOLDER\HERE"
    ext = "ENTER FILE EXTENSION HERE"

    Set OL = CreateObject("Outlook.Application")
    Set EmailItem = OL.CreateItem(olMailItem)

    'Make sure file xlWbName.ext is closed or close it before running the next line
    Shell "C:\Program Files\7-Zip\7z.exe" & " a -tzip """ & xlWbPath & "\" & xlWbName & ".zip"" """ & xlWbPath & "\" & xlWbName & ext & """"

    With EmailItem
        .Subject = "Enter subject here"
        '.Body = ""
        .To = "somewhere@maildomain.com"
        '.Cc = ""
        '.Bcc = ""
        .Importance = olImportanceNormal
        .Attachments.Add xlWbPath & "\" & xlWbName & ".zip"
        .Display
    End With

    Set OL = Nothing
End Sub

我测试了上面的代码，它成功附加了压缩文件。

通过电子邮件发送活动工作簿的压缩版本

2 个答案: