添付ファイルを自動的に圧縮するマクロ


メッセージにて以下のようなご要望を頂きました。


添付ファイル付きメールを送信時に自動的に LHA 圧縮出来れば便利だと思います。


まず、圧縮方法についてですが、全ての環境で LHA による圧縮や展開ができるわけではないので、Windows XP や Vista の標準機能として使用可能な ZIP による圧縮の方が良いでしょう。
また、圧縮で何らかのエラーが発生した場合を考えると、送信時に自動的に行うよりはユーザーのオペレーションによる方が安全ではないかと思いました。
そこで、下記のようなマクロを作ってみました。このマクロを実行するとメッセージの添付ファイルを全て ZIP で圧縮し、"元のファイル名.zip" という名前で添付します。何らかの理由でエラーが発生した場合はメッセージを変更せずにクローズすることで、直前のメッセージを下書きなどから取り出すことができます。(ちょっと記述を変更し、ItemSend イベントで呼び出せば、送信時に圧縮させることも可能です。)

なお、このマクロを実行すると添付ファイルの位置がずれたり、順序が入れ替わることがありますので、あらかじめご了承ください。

' ここをトリプル クリックするとマクロ全体が選択できます。
' 下記の 1 行はマクロ ファイルの先頭にコピーしてください。
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
' ZIP 圧縮を行う VBA マクロ
Public Sub ZipCompressAttachment()
    Dim objShell ' As Shell32.Shell
    Dim objFS ' As Scripting.FileSystemObject
    Dim strTemp As String
    Dim fldTemp ' As Scripting.Folder
    Dim objItem ' As MailItem
    Dim i As Integer
    Dim objAttach As Attachment
    Dim strAttach 'As String
    Dim strEmptyZip 'As String
    Dim strZipFile 'As String
    Dim stmZipFile ' As Scripting.TextStream
    Dim fldZip ' As Shell32.Folder
    ' SHELL オブジェクトと FileSystemObject オブジェクトを生成
    Set objFS = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    ' 作業フォルダの作成 (%TEMP% で指定される一時フォルダの下にランダムな名前のフォルダを作成)
    strTemp = objFS.GetSpecialFolder(2) & "\" & objFS.GetTempName()
    Set fldTemp = objFS.CreateFolder(strTemp)
    ' 作成中のアイテムを取得
    Set objItem = ActiveInspector.CurrentItem
    ' 作成中のアイテムを一旦保存
    objItem.Save
    ' 添付ファイルの一つ一つについてチェック
    For i = objItem.Attachments.Count To 1 Step -1
        Set objAttach = objItem.Attachments.Item(i)
        ' 既に ZIP で圧縮済みなら圧縮しない
        If Not objAttach.FileName Like "*.zip" And objAttach.Type = olByValue Then
            ' 作業フォルダに作成するファイルの名前を取得
            strAttach = strTemp & "\" & objAttach.FileName
            strZipFile = strAttach & ".zip"
            ' 作業フォルダに添付ファイルを保存
            objAttach.SaveAsFile strAttach
            ' 空の ZIP ファイルを作成
            strEmptyZip = Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(20, 0)
            Set stmZipFile = objFS.CreateTextFile(strZipFile, True, False)
            stmZipFile.Write strEmptyZip
            stmZipFile.Close
            ' ZIP ファイルをフォルダとして取得し、添付ファイルをコピー
            Set fldZip = objShell.NameSpace(strZipFile)
            fldZip.CopyHere strAttach, 16
            ' ZIP ファイルの圧縮は非同期で行われるため、コピーが終わったかどうかをファイルがオープンできるかどうかで判断
            On Error Resume Next
            Do
                DoEvents
                Sleep 5000
                Err.Clear
                Set stmZipFile = objFS.OpenTextFile(strZipFile)
            Loop While Err.Number <> 0
            stmZipFile.Close
            On Error GoTo 0
            ' 添付ファイルと ZIP ファイルを入れ替え
            objAttach.Delete
            If objAttach.Position = 0 Then
                objItem.Attachments.Add strZipFile, olByValue, , objAttach.DisplayName
            Else
                objItem.Attachments.Add strZipFile, olByValue, objAttach.Position, objAttach.DisplayName
            End If
            ' 作業フォルダのファイルを削除
            objFS.DeleteFile strAttach
            objFS.DeleteFile strZipFile
        End If
    Next
    ' 作業フォルダを削除
    fldTemp.Delete
End Sub

マクロの登録方法やメニューへの追加について

広告

添付ファイルを自動的に圧縮するマクロ」への36件のフィードバック

  1. このサイトを見つけて、大変助かっております。
    実は、イントラネット上のメールの全文検索を作りたくて、試行錯誤しています。
    アウトルックのルールで全文検索システムにメールを転送しているのですが、
    全文検索システムがUTF8で添付ファイルを認識するので、ファイル名が文字化けしてしまいます。
    幸い、ZIPファイルは中身までインデックス化してくれるので
    \’            strZipFile = strAttach & ".zip" 行を            strZipFile = COMPRESS & ".zip" のように変更することで、
    COMPRESS.zipという英字名のファイルで転送できそうな気がしてきました。
     
    さらに欲を言えば、添付ファイルで固定文字列のパスワードをつけているワード等があるのですが、
    パスワードがついていると、インデックス化されないため
    マクロでパスワードを除去した上で圧縮転送できれば、最高です。
    もっと、よい方法があるかもしれませんが、こんな複雑なこともマクロで可能でしょうか?
     

  2. オブジェクト変数またはwithブロック変数が設定されていません・・・とエラーメッセージが出ます。最初の一行はマクロの最初に記述されています。(このマクロしか設定していないので当たり前ですが)
     

  3. To (名前なし) さん
    使用しているOutlookのバージョンはいくつでしょうか?
    また、どのような状態でマクロを実行していますか?
    例えば、このマクロを実行するときに、添付ファイルを圧縮したいメッセージを開いておかないとエラーになります。

  4. 初めまして。m(_ _)m職場でOutlookを使うようになり、こちらのブログにたどり着きました。上記マクロをメールの新規作成で、添付ファイルを挿入した状態で実行したところ、「オブジェクト変数またはwithブロック変数が設定されていません」というエラーメッセージが表示されます。(名前なしさんと一緒です)★マークの実行行でエラーが発生しているようでした。——————————————————————————– \’ ZIP ファイルをフォルダとして取得し、添付ファイルをコピー Set fldZip = objShell.NameSpace(strZipFile) ★ fldZip.CopyHere strAttach, 16—————————————————————————–strZipFile には、添付ファイルのパスが格納されているのですが、fldZipの値が、「nothing」の状態で、★の行を実行しようとしています。バージョンはOutlook2003です。よろしくお願いいたします。

  5. To 307 さんobjShell.NameSpace で取得された fldZip が Nothing になっているということは、お使いの環境では ZIP ファイルをフォルダとして取得することができないと考えられます。おそらく Windows XP 以降なら使用できるはずですが、お使いの Windows のバージョンはいくつでしょうか?

  6. こんばんはっ。ご返事ありがとうございますm(_ _)m。自宅の環境(XP+Outlook2003)と職場の環境(VISTA+Outlook2007)で試したのですが、双方とも同じ箇所で同じエラーになってしまいました。よろしくお願いします。

  7. To 307 さん回答が遅くなりましてすみません。理由はよくわからないのですが、strZipFile を String 型で定義するとエラーになる場合があるようです。スクリプトを修正しました。

  8. こんにちはっ。ご回答ありがとうございます。m(_ _)m修正いただいた、マクロファイルを貼りつけ直して実行したところ、エラーは発生せず、メールの添付ファイルは「添付ファイル名.zip」に変わりました。ただ、zipフォルダを開いたところ、中身が空の状態でした。 fldZip.CopyHere strAttach, 16  の実行後に、zipフォルダ内にファイルがコピーされると思っていたのですが・・。  fldZipの値は、「ファイル名.拡張子.zip」  strAttachの値は、「フルパス\\ファイル名.拡張子」 でした。もう少しOutlookのVBA基礎を勉強して、自己解決に挑戦したいと思います。また、報告させていただきます。ありがとうございました。m(_ _)m

  9. To 307 さんstrAttach の方も String 型で定義していたのが悪かったようです。再度スクリプトを修正してみましたので、こちらで試してみてください。

  10. おはようございます。修正後のマクロで、無事に圧縮することができました。重要なのは、データ型なんですね。勉強になりました。ありがとうございました。m(_ _)m

  11. こんばんわ。>ユーザーのオペレーションによる方が安全ではないかたしかに安全を考えればそうなのですが、実際送信時に自動で圧縮したいと思うことも多々あります。僕は少しでも楽にしていきたいと考えていますが、VBAは初心者です。わけもわからないままこのサイトにいきつきました。マクロの登録もなんとかできました。ですが、やっぱり送信時に圧縮できればなとなんども思います。>ちょっと記述を変更し、ItemSend イベントで呼び出せば、送信時に圧縮させることも可能です。具体的にはどこを変更すればいいのでしょうか?教えてください。また、outlookのVBA・マクロ関係の参考書が見当たりません。なにか良い参考書があれば教えていただきたいです。図々しいとは思いますがよろしくお願いします。

  12. To 2.8 さん以下のように修正すれば、送信時に自動的に圧縮できるようになります。1. Public Sub ZipCompressAttachment() を以下の通り書き換える。Private Sub objOL_ItemSend(ByVal objItem As Object, Cancel As Boolean)2. 以下の行を削除する。 Dim objItem \’ As MailItem3. 以下の行を削除する。 \’ 作成中のアイテムを取得 Set objItem = ActiveInspector.CurrentItem \’ 作成中のアイテムを一旦保存 objItem.Saveただ、ItemSend イベントの中で添付ファイルの追加などを行うと、挿入位置が正しく指定できないという問題があるようですので、あまりお勧めはしません。

  13. おはようございます。記述とおりに直したのですが、うまく圧縮されません。マクロに登録もできませんでした。Public Subだと登録はできます。Private Subだと[ツール]-[マクロ]-[マクロ…]で参照しても表示されません。すみません。ご教授お願いします。

  14. To 2.8 さんすみません。Public Sub ZipCompressAttachment() は以下の通り書き換えてください。Private Sub Application_ItemSend(ByVal objItem As Object, Cancel As Boolean)また、送信時に自動的に圧縮する場合、マクロは [ツール]-[マクロ]-[マクロ] で実行することにはなりませんので、こちらには表示されなくてもかまいません。むしろ、表示されるべきではありません。

  15. Application_ItemSendに書き換えてみたのですが、うまく圧縮できなかったので、このサイトにあります「空白の件名をチェックするマクロ」をためしたところ、これも作動することがありませんでした。僕のoutlook2003の設定がおかしいのでしょうか。ご教授ください。お願いします。

  16. さきほどのコメントは気にしないでください。ThisOutlookSessionに入れることをすっかり忘れていました。お恥ずかしい限りです。無事に動作することができました。感謝しております。ちなみに気になることが2つほどあります。①このマクロ(に限らず全てのマクロ)はメイン画面のツールバーにマクロを挿入することができたのですが、 メッセージを作成する画面ではマクロの挿入ができません。これは仕様なのでしょうか?②txtファイルは圧縮できたのですが、Jpgなどの画像ファイルは圧縮できたものの、中身は壊れていて解凍できませんでした。 対処方法はないのでしょうか?教えてください。なんどもすみません。

  17. To 2.8 さん1. についてですが、メインの画面に追加できるマクロであれば、メッセージ作成の画面でも追加できるはずです。手順をご確認ください。2. についてですが、私の環境では JPG でも正しく圧縮できました。環境に依存する問題なのかもしれませんね。原因がわからないので、対処方法として正しいかどうかわかりませんが、Sleep 5000 の値を増やしてみてください。

  18. Millefeuilleさんに感謝いたします!Sleep 5000を15000に増やしてみたところ、Jpgやpdfファイルがちゃんと圧縮されました!ここでまたまた質問です。①sleepは一番初めに宣言した kernel32のAPI関数を使用している所まではわかったのですが、このマクロのsleep自体はなんの作業をしているのでしょうか? sleepが何かの作業をしている時に指定時間まで停止するみたいなのですが…。②この値は少なすぎたり、多すぎたりした場合はどうなるのでしょうか?少ない場合は環境によって動作しないことはわかったのですが…。早く圧縮したいときは少ない数値のほうがいいとかではないですよね?③ZIP圧縮作業のスレッドとメインの作業(メール送信)を並列しておこなうためにsleepを使用していたのでしょうか?うーん、もう少しsleepについて調べていきたいと思います。なんども質問ばかりですいません。少しでもVBAについて理解したいと思ってます。

  19. To 2.8 さんいただいたご質問に回答します。1. Sleep は「何もせずに待機する」という処理をします。CopyHere というコマンドは実行すると実際の処理が終わっていなくても制御が Outlook に戻ってしまうので、何もせずに待機する必要があるのです。2. 値が小さすぎると圧縮作業が始まる前に Outlook に制御が移り、圧縮中のファイルを添付してしまうようです。また、値が大きすぎる場合、一つ一つの添付ファイルの圧縮の際の Outlook の待機時間が長くなります。たとえば、15000 という数字にすると、1 ファイルあたり 15 秒待つことになるので、4 つファイルを添付すると最低でも 1 分はかかってしまうのです。3. 1. の回答と重なりますが、Sleep は単に待機するために使用しています。ZIP 圧縮とメール送信を並列して行うわけではありません。むしろ並列で処理ができないので、ZIP 圧縮を待つために Sleep を実行しているということになります。

  20. こんにちは。Millefeuilleさんにはいつもお世話になっております。sleepを使う理由がよくわかりました!outlookに戻されると困るので待機する必要があったのですね。15000だとおっしゃるとおりで時間がかかってしまいました。5000に戻してみた所、正常にうごきました。なんだったんだろう…。毎回質問ばかりで申し訳ないのですが、わかる範囲でよろしいので教えてください。①ZIP以外の圧縮方法はあるのでしょうか?例えば会社などでよくつかわれる拡張子 LHAやLZHです。おそらく Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(20, 0) ここを変更すれば、できるものかと思ったのですが、僕の知識ではうまく答えを導けませんでした。②outlookにはマクロやVBAがあるのにoutlook expressにはマクロやVBAがないのはなぜでしょうか? 単純にofficeソフトとの差別化を図るため?マクロやVBAがない理由を知りたいのですがMillefeuilleさんはなにか知っていますでしょうか?ご教授ください。よろしくお願いします。

  21. To 2.8 さんいただいたご質問に回答します。1. LZH での圧縮は Windows の標準機能ではできません。LZH 形式で圧縮できるプログラムを呼び出す必要があります。LHA などのソフトをインストールすれば、それを呼び出すことでおそらくマクロでも出来ると思いますが、ZIP で何か問題があるのでしょうか?ちなみに、 Chr(80)… を変更しても LZH 形式にはできません。それほど単純な話ではないのです。2. Outlook Express にマクロがない理由は私も知りません。ただ、無償のソフトウェアにそこまで望むのは酷ではないでしょうか?それに、Outlook Express を使うユーザーの大半はマクロのような高度な機能を必要とするとは思えません。Outlook のマクロですら、おそらくほとんどのユーザーは使っていないでしょう。

  22. 素朴な疑問です。①For文でなぜ Step -1 なのでしょうか?ZIP圧縮するだけなので-1じゃなくてもよいきがしますが…。1 Step1だと、ファイルを調べる数に限界がくるなんてことはないですよね?②Dim strTempはStringですが、Dim strAttachはなぜ、 \’As Stringとコメントで消しているのでしょうか?ご教授ください。すみません。

  23. To 2.8 さんいただいた質問に回答します。1. For ループの中でループのもとになっている Attachments を削除しているので、Step -1 にしています。たとえば、att1、att2、att3 という 3 つの添付ファイルがあったとき、Step 1 で 1 から 3 の順に処理すると、att1 を削除したタイミングで、att2 が 1 番目となります。そうなると、次のループで 2 番目の要素をとりだしたときには att2 ではなく att3 となってしまい、att2 が処理されないのです。2. 当初は As String で定義していたのですが、どういうわけか CopyHere などで正しく認識できないことがあり、String をやめました。経緯はこの記事のコメントをすべて読んでいただければわかるかと思います。

  24. なるほど。処理の微妙なタイミングで-1ではないとダメなんですね。ありがとうございます。コメントを全部読んでいませんでした。もっと色々調べてみます。

  25. なんどもすみません。①\’ 空の ZIP ファイルを作成のあと、\’ ZIP ファイルをフォルダとして取得し、添付ファイルをコピーとありますが、ZIP をフォルダとして取得している状態で、添付ファイルを複数コピーすることはできますか?ようは、フォルダを選択(GetOpenFilenameなどで)してフォルダの中にある複数のファイル(サブフォルダは無視、ファイルのみ)を作業フォルダの中にいれて、そのままZIP化してから添付してしまう ということです。このページで紹介されている圧縮マクロだと、複数のファイルがあれば、すべて1つずつ圧縮して添付をしますが、その場合一つひとつファイルを開かなくてはなりません。なので、フォルダごとZIP化して、ひとつのZIPをひらけば、フォルダがあり、そのなかにファイルがいくつか入っている というのを作りたいです。②このページのマクロは最後に作業フォルダを削除していますが、これを削除しなかった場合どうなるのでしょうか?削除せず、作業フォルダに添付ファイルが入ってしまえば、あとは圧縮するだけなのですが・・・。なんどもすみませんご教授ください。お願いします。

  26. To 2.8 さんもはや Outlook と関係の無い話になっていますね。サンプル提供もできますが、このブログの趣旨にそぐわないように思いますので、ヒントだけ。1. については答えは「可能」です。Shell.Application の NameSpace がどのような意味を持つか、また CopyHere がどのような意味を持つかということを調べれば、やり方もわかるでしょう。2. についてはマクロをちょっと変更して試してみればお分かりになるかと思いますが、作業フォルダを削除しなければ作業フォルダが残るだけです。もし少しでもプログラミングが上達したければ、人に聞く前に自分でいろいろプログラムを変更して試してみたほうが良いですよ。

  27. MillefeuilleさんZIP圧縮をするとき、パスワードつきのZIP圧縮を作成することは可能なのでしょうか?パスワードの値はあらかじめ(フォームなどで設定して)自由に決められるようにして、レジストリに値を保存。自動で圧縮するさいにレジストリから値を読み込み、値を取得します。SaveSettingでレジストリに保存し、GetSettingでレジストリの値を取得できる所までは確認できました。ZIP圧縮のマクロに上記の機能を追加して、パスワード付きのZIP圧縮はできますでしょうか?ご教授ください。よろしくお願いします。

  28. To 2.8 さんWindows の標準機能で ZIP 圧縮の際にパスワードを設定することはできません。フリーウェアなどでパスワード付きの ZIP 圧縮ができるものをインストールし、WScript.Shell オブジェクトの Run メソッドでそのプログラムを呼び出すようにすればできると思います。

  29. Millefeuilleさん いつもお世話になっております。回答ありがとうございます。さっそくパスワード付きの圧縮ができるという"Lhaplus"というフリーウェアを使って、なんとかならないかと考えました。これでソフトの表示はできたのですが、圧縮する際にパスワードを聞くというところまで作成はできませんでした。どうすればいいのでしょうか?パスワード付きZIP圧縮ができればよいので、あらかじめ決めてあるパスワードの文字を取得し圧縮の際にその値をパスワードにするといった方法でもかまいません。Public Sub aaa()Dim objWShell \’WScript.ShellDim vPassWord As Variant\’ WScript.Shellを生成Set objWShell = CreateObject("WScript.Shell")\’ レジストリに保存してあるパスを取得 ここでは→"C:\\Program Files\\Lhaplus\\Lhaplus.exe"vPassWord = GetSetting("MyMacro", "sample", "Pass")objWShell.Run vPassWord, vbNormalFocus, FalseSet objWShell = NothingEnd Subお手数をお掛けし大変申し訳ありませんがよろしくお願いします。

  30. To 2.8 さん大変申し訳ありませんが、私は Lhaplus というソフトウェアの使い方はわかりませんので、こちらを使ってパスワードを設定する方法はそのソフトウェアのサポートに問い合わせてみてください。また、ファイルに圧縮に関しては Outlook とは無関係の話なので、今後この手の質問に対してはお答えいたしかねます。他の開発系の掲示板をあたってください。

  31. 2.8 さんのようにパスワード付きの圧縮をしたいと考え、Millefeuilleさん のアドバイスのありましたWScript.Shell オブジェクトの Run メソッドから所定のツールを起動し、目的を実現することができました。

    更に欲がでてきて、複数ファイルを格納したフォルダを指定した暗号化をしたいと考えています。

    しかし、メール作成ウィンドウにフォルダをドラッグ&ドロップすると、【! 添付できるのは、ファイルかオブジェクトに限られています。”c:\******\****”(ドロップしたフォルダ名)はフォルダなので、添付できません】
    というポップアップが表示されてしまいます。

    そこで、お知恵をお貸しください。

     上記マクロをファイルが添付された際のイベント時に起動されるマクロとして定義できれば、パラメタにファイル名を取得して先述のWScript.Shell オブジェクトの Run メソッド でアーカイブしたファイルに
    変換して添付するという実装にできないでしょうか?

    それとも、ファイルが添付されたイベントがキックされる前に、OUTLOOK側でフォルダチェックし、上記のポップアップが表示されてしまい、上記のような実装はNGでしょうか?

    • Outlook に限らず、電子メールにフォルダーを添付することはできません。
      そのため、フォルダーごと添付したいのであれば、添付処理の前にフォルダーを圧縮フォルダー(ZIP)として一つのファイルにする必要があります。

    • 上記のマクロではZIPのファイル名をループ内でファイルごとに指定していますが、これをループ外で設定して一つの ZIP ファイルにコピーするようにすればまとめて圧縮できると思います。

コメントを残す

以下に詳細を記入するか、アイコンをクリックしてログインしてください。

WordPress.com ロゴ

WordPress.com アカウントを使ってコメントしています。 ログアウト / 変更 )

Twitter 画像

Twitter アカウントを使ってコメントしています。 ログアウト / 変更 )

Facebook の写真

Facebook アカウントを使ってコメントしています。 ログアウト / 変更 )

Google+ フォト

Google+ アカウントを使ってコメントしています。 ログアウト / 変更 )

%s と連携中