2017年6月
        1 2 3
4 5 6 7 8 9 10
11 12 13 14 15 16 17
18 19 20 21 22 23 24
25 26 27 28 29 30  

« ◆Outlook VBA(タイトルバーの動的変更) | トップページ | ▼ダイエット大作戦(風邪ひいてしまいました) »

2007年4月 7日 (土)

◆Outlook VBA(複数メールの添付ファイルを一括保存)

今回はOutlookメールの添付ファイルを保存する機能について書いてみたいともいます。前回のカスタマイズ記事でカスタムメニューの画像を出していたのでネタばれだったかもしれませんね。

1つのメールに添付されているファイルを保存する機能は標準でありますね。メニュー「ファイル」→「添付ファイルの保存」→「すべての添付ファイル」です。でも複数メールの添付ファイルを一括保存する場合、あれっできない?Microsoftさん!?。。。

2010.9.10加筆
保存先に同じファイル名が存在したら重複しないように枝番を付加するように改良したヴァージョンは
こちら

ということで作成したのが以下の処理です。

Sub 選択メールの添付ファイルを指定フォルダに一括保存()
    Dim cDir As String, oSel As Object, oF As Object
    Dim myOlApp As New Outlook.Application
    Dim myOlExp As Outlook.Explorer
    Dim myOlSel As Outlook.Selection
    Dim myNameSpace As Outlook.NameSpace
    Dim myFolder As Outlook.MAPIFolder
    Dim mySendFolder As Outlook.MailItem
    Dim myCopiedItem As Outlook.Items
    Dim lMax As Integer, i As Integer
    Dim MyTitle As String
    Dim Leng As Long, hWnd As Long, ret As Long
   
    Dim myAttachments As Outlook.Attachment
    Dim MsgTxt As String, a As String
    Dim myExlApp As Object, Files As Object
    Dim lSubject As String
   
    On Error Resume Next
    Set myOlApp = CreateObject("Outlook.Application")
    Set myOlExp = myOlApp.ActiveExplorer
    Set myOlSel = myOlExp.Selection
   
    Set myExlApp = CreateObject("excel.Application")
    cDir = myExlApp.GetSaveAsFilename("DUMMY", "全ファイル(*.*),*.*", , "保存先フォルダ指定")
    If cDir = "False" Or cDir = "FALSE" Then GoTo p_exit
   
    cDir = Mid(cDir, 1, InStrRev(cDir, "\") - 1)
   
    '現在のウィンドウタイトル取得
    hWnd = GetActiveWindow()
    MyTitle = String(250, Chr(10))
    Leng = Len(MyTitle)
    ret = GetWindowText(hWnd, MyTitle, Leng)

    '選択されたメールの添付ファイルを保存
    For Each oSel In myOlSel
        i = i + 1
        ret = SetWindowText(hWnd, oSel & "(" & i & "/" & myOlSel.Count & ")" & "を処理中...")
        For Each oF In oSel.Attachments
            oF.SaveAsFile cDir & "\" & oF.DisplayName
        Next
       
    Next
   
    ret = SetWindowText(hWnd, MyTitle)
    MsgBox "終了しました。総数:" & i
    ret = Shell("c:\windows\explorer.exe " & cDir, vbNormalFocus)

p_exit:
    Set myExlApp = Nothing
    Set oSel = Nothing
    Set oF = Nothing
    Set myOlApp = Nothing
    Set myOlExp = Nothing
    Set myOlSel = Nothing
   
End Sub

解説すると、例のごとくSet myOlApp = CreateObject("Outlook.Application")でOutlookオブジェクトを作成し、Set myOlSel = myOlExp.Selectionで選択されているメールを取得します。Set myExlApp = CreateObject("excel.Application")でExcelのオブジェクトを生成し、ExcelのGetSaveAsFilename関数をフォルダ指定に流用しています。ここは"shell.application"のbrowseforfolderでも良いし他にもあるかもしれません。ちなみに、予めChDirをしたかったのですが、Outlookは有効にならないようです。For Each oSel In myOlSelで選択したメール分処理を繰り返します。さらに、For Each oF In oSel.Attachmentsでメールに添付された複数ファイル分処理を繰り返します。あとは、前回説明したタイトルバーの変更処理が含まれていますが割愛します。

以上が添付ファイルの一括保存についての説明でした。OutlookVBAについては今回で終了とします。また、ネタが見つかったら書いてみたいと思います。

※私が作成したVBAツールです。よかったら使ってみてください。

« ◆Outlook VBA(タイトルバーの動的変更) | トップページ | ▼ダイエット大作戦(風邪ひいてしまいました) »

パソコン・インターネット」カテゴリの記事

コメント

◆Outlook VBA(複数メールの添付ファイルを一括保存)について◆

こんにちは。
私はExcelVBAは多少、利用しておりますが、OutlookVBAに関しては初心者です。
上記、VBAコードをVBAエディターへ貼り付け、Outlook受信フォルダ表示のツール>マクロ>からマクロ実行したところ、

"コンパイルエラー: Sub または Function が定義されていません"

と表示され、

'現在のウィンドウタイトル取得
hWnd = GetActiveWindow()

の、 GetActiveWindow コードが反転しました。

OfficeXPでの利用ですが、此方のVBAマクロを使用することは出来ませんでしょうか? 宜しくお願いいたします。

こんにちはkemuru さん

◆Outlook VBA(タイトルバーの動的変更)にも記述していますが、私が公開しているマクロを実行するにはWindows APIを定義する必要があります。
subプロシージャよりも上段に以下を定義してください。

'アクティブウィンドウハンドルを取得する
Private Declare Function GetActiveWindow Lib "USER32" () As Long

こんにちわ。
こういうマクロは非常にありがたいですね。フルに使わせていただいています。これで保存時に

「同じファイル名のものがあればファイル名を変えるかどうか聞いてくる(変えることができる)」

ようなことができるとありがたいのですが・・・。ともあれ、シェアしていただきありがとうございます。

mydayさん
こんにちは
お役に立ててうれしいです。
同一ファイル名の件ですが、私は一時保存した後
に別フォルダに移動する運用なので考えもしません
でしたが、あれば便利かもしれませんね。
VBAで十分実現可能なので時間があるときに
作ってみようと思います。

非常に参考になります。かなり活用させていただいています。

「ファイルの保存先に同名のファイルが存在した場合には、ファイル名に -1、-2 というように数字をつけて上書きが発生しないようなファイル名にする」

というようなことができるとありがたいのですが、可能でしょうか?(前述のコメントと少しかぶりますが・・・)

今のままでもかなり助かっています。感謝です!

nobuoさん、おはようございます。
返信が遅くなりすみません。
トップ記事にご要望の改良版を公開しました。
使って見て感想などお聞かせください。
よろしくお願いします。

完璧です!ほんとにイメージどおり作っていただきありがとうございます!
9月にすぐアップされていたのを確認して以来、フルに活用させていただいているのに、お礼をするのを失念していました・・・。(ほんとにすみません)
今後も、何かわからないことがあればお聞きしますので、お時間がある時で結構ですので回答いただけると幸いです!

nobuoさん、こんにちは。
ご丁寧なコメントいただきましてありがとうございます。自分の都合で作成したツールですが、喜んで頂いてとても嬉しいです。自分の想定しなかった使い方などこちらも勉強になります。何か要望があればご指摘くださいね。

コメントを書く

(ウェブ上には掲載しません)

« ◆Outlook VBA(タイトルバーの動的変更) | トップページ | ▼ダイエット大作戦(風邪ひいてしまいました) »