アクティブブックの圧縮バージョンをメールしてください

Question

Outlookを使用してブックの圧縮コピーを電子メールで送信します。 Zipブックを添付するように、以下のマクロをどのように拡張しますか？

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