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

仕事で使用するのに、活用させていただきます!
保存先フォルダの選択画面が出てこず、タスクマネージャーを起動すると、確かにアプリケーションが起動されており、切り替えボタンを押すとフォルダ選択の画面が立ち上がります。
タスクマネージャーを起動し、切り替えせずとも、立ち上がる方法はありますでしょうか。

こんにちは、koya 様。
上記で公開しているソースが、自分の手元にあるソースとちょっと違いますね。
以下の通りに書き換えてみてください。

■現在ソース-----------------



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)

'現在のウィンドウタイトル取得

■書き換えソース-----------------



cDir = GetFolder()
If cDir = "キャンセル" Then GoTo p_exit


'現在のウィンドウタイトル取得

--------------------------------
書き換えたソースでは動作しているので、お試しください。

初心者すぎてご迷惑をおかけします。
教えていただいた通り、Set myExlApp 以降を書き換えてみたのですが、
コンパイルエラー:SubまたはFunctionが定義されていません。となります。
ご教示お願いできますでしょうか。

koya 様。大変失礼いたしました。私のミスです。
以下のソースを上記と同じモジュール内に貼り付けてみてください。

Private Function GetFolder() As String
Dim objShell As Object
Dim objFolder As Object
Const strTitle As String = "フォルダを選択してください"
Const lngRef = &H1
Const lngRoot = &H0

Set objShell = CreateObject("shell.application")
Set objFolder = objShell.browseforfolder(0, strTitle, lngRef, lngRoot)

If objFolder Is Nothing Then
GetFolder = "キャンセル"
Else
If objFolder.parentfolder Is Nothing Then
GetFolder = "デスクトップ"
Else
GetFolder = objFolder.Items.Item.path
End If
End If

Set objShell = Nothing
Set objFolder = Nothing
End Function

何度も何度も申し訳ありません。
↓の上にコンパイルエラー End Subが必要です。と表示されます。
Private Function GetFolder() As String

koya さんですか。
こんにちは。

推測ですが、End Subと言われているということは、ソースを貼り付けた際に、直上のEnd Subを削ってしまったのではないのでしょうか。
確認してみてください。
ソース自体の問題ではないと思います。

やはり、うまくできなかったです。。
タスクマネージャーを起動すれば
使用できないことはないので、しばらくはそうやって使用します。
そして、少し勉強してみます。
ご丁寧にありがとうございました

コメントを書く

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

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