« @アニメ(2010夏アニメOP、ED) | トップページ | @アニメ(2010秋アニメOP、ED) »

2010年9月 7日 (火)

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

ご無沙汰のOutlook VBAネタです。
コメントを頂きましたので一括保存マクロを改良してみました。
一括保存する際に同じファイル名があったらファイル名が重複しないようにファイル名_1というように
枝番を付加するように改善しました。
アンダーバーが趣味ではないという方は以下の部分をいろいろ変更してみてください。
例えば、
lVal = lVal & "_" & cnt & Mid(oF.DisplayName, InStrRev(oF.DisplayName, "."))

lVal = lVal & "(" & cnt & ")" & Mid(oF.DisplayName, InStrRev(oF.DisplayName, "."))


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
    Dim fs As Object
    Dim lpath As String, lVal As String
    Dim cnt As Integer
   
    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)

    Set fs = CreateObject("Scripting.FileSystemObject")
    '選択されたメールの添付ファイルを保存
    For Each oSel In myOlSel
        i = i + 1
        ret = SetWindowText(hWnd, oSel & "(" & i & "/" & myOlSel.Count & ")" & "を処理中...")
        For Each oF In oSel.Attachments
            lpath = cDir & "\" & oF.DisplayName
            If Not (fs.FileExists(lpath)) Then
                oF.SaveAsFile lpath
            Else
                cnt = 0
                Do Until Not (fs.FileExists(lpath))
                    cnt = cnt + 1
                    lVal = Mid(oF.DisplayName, 1, InStrRev(oF.DisplayName, ".") - 1)
                    lVal = lVal & "_" & cnt & Mid(oF.DisplayName, InStrRev(oF.DisplayName, "."))
                    lpath = cDir & "\" & lVal
                Loop
               
                oF.SaveAsFile lpath
            End If
        Next
       
    Next
   
    ret = SetWindowText(hWnd, MyTitle)
    MsgBox "終了しました。総数:" & i
    ret = Shell("c:\windows\explorer.exe " & cDir, vbNormalFocus)

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

« @アニメ(2010夏アニメOP、ED) | トップページ | @アニメ(2010秋アニメOP、ED) »

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

コメント

参考にさせて頂きました。ありがとうございます。

こちらで解説されていた、アドレス帳を参照するマクロと組み合わせて、ファイル名に差出人名を追加して保存するようにしました。

http://outlooklab.spaces.live.com/blog/cns!9D7EA61EC7DAA750!177.entry?wa=wsignin1.0&sa=918396854

インターネットFAXで色々な店舗からFAXが送られてくるのを都度保管しているのですが、かなり効率が改善されました。

完璧です。
すばやいレス、ほんとにありがとうございます。平陽凛さんの技術力、おそるべしです!

ありがたく使わせていただきました。
ところで、マクロを実行したところ最後に表示されるファイル件数と、実際に保存されているファイル数が合わないことがあります。
よくよく確認してみると、2MB以上は保存されないようなのですが、なにが原因かお分かりになりますか??

こんばんは、平陽凛です。
お名前が無いようですが、コメントします。返信が遅くなりすみません。
まず、ファイル件数についてですが、表示している件数は選択しているメールの件数で、添付されているファイル数ではありません。
2MB以上のファイルが保存されない件ですが、こちらで確認したところ、きちんと保存されることが確認できています。ロジックで特に制限は設定していません。保存先のフォルダでしょうかね。

hWnd = GetActiveWindow()
でコンパイルエラー
sub functionが定義されていませんのエラー
が出ます。
宜しくお願いします

鈴木さん

こんにちは、平陽凛です。
下記の設定を標準モジュールの先頭に追加してみてください。これはVBAの標準関数では実現できない機能を呼び出すためのWindowsAPIです。

'アクティブウィンドウハンドルを取得する
Private Declare Function GetActiveWindow Lib "USER32" () As Long
'ウィンドウハンドル取得
Private Declare Function FindWindow Lib "USER32" Alias "FindWindowA" ( _
ByVal lpszClass As String, ByVal lpszWindow As String) As Long
'ウィンドウタイトル変更
Private Declare Function SetWindowText Lib "USER32" Alias "SetWindowTextA" (ByVal hWnd As Long, ByVal lpString As String) As Long
'ウィンドウタイトル変更
Private Declare Function GetWindowText Lib "USER32" Alias "GetWindowTextA" (ByVal hWnd&, ByVal lpString$, ByVal cch&) As Long

こんにちは、投稿拝見させていただきました。
2つ質問がありコメントさせていただきました。
1つ目は、拡張子が.msgの添付ファイルの保存方法。
2つ目は、ファイル名に差出人名を追加して保存する方法です。
ご教示のほどよろしくお願いします。(o^-^o)

参考にさせていただきました。

ERP導入後「注文書自動発行→PDFでメール配信される」のですがメール1件に注文書1枚なんです。一括印刷機能も付けてほしかった・・・

でも、このブログのおかげで解決です。
ありがとうございました。

平陽凛様

OUTLOOK 2007 マクロド素人のmihiroです。
はじめまして。

実はご相談なんですが、受信したある特定の件名を’ABC’として、それに付いてくる添付ファイルのみ、PCの指定フォルダのC¥DEF¥へ保存したいのですが、マクロがよくわかりませんので、ご教示いただけたら幸いかと存じます。

新年早々から本当に申し訳ございませんが、どうか宜しくお願いします。

mihiro様
こんばんは。

ご質問の内容と、当方が公開しているマクロでは
だいぶ仕様が異なるようです。
おそらく、メールの件名から自動的に判別して、
その添付ファイルをフォルダに保存するものと
推察します。

当方の仕様は選択したメールの添付ファイルを一括保存ですが、選択したメールのうち、件名がabcだったら、フォルダに保存するということであれば、少しの改造で実現できると思います。
これに沿ったマクロを公開する予定はありませんが(笑)、ヒントをいくつか。
まず、件名の判定は以下でできます。
If oSel.Subject = "ABC" then

さらにフォルダの作成は以下でできます。
  cDir ="c:\DEF"
If Dir(cDir, vbDirectory) = "" Then
MkDir cDir
End If
これらを組み込めばできると思います。
お試しください。

コメントを書く

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

« @アニメ(2010夏アニメOP、ED) | トップページ | @アニメ(2010秋アニメOP、ED) »