2017年12月
          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
31            

« @アニメ(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
これらを組み込めばできると思います。
お試しください。

はじめまして。
このブログを拝見しまして、似たような事をしたくてご教示いただけないでしょうか。
(記事が数年前なので気づいていただける事を祈りつつ苦笑)

作業対象メールはすべて受信トレイの「作業」という名前のフォルダにあるとします。
作業フォルダにある数十件メールにはそれぞれ色んなPDFがついているのですが、必ず「ご案内」という名前が含まれるPDFが添付されています。

→所定フォルダにあるメールの指定した名前を含むPDFだけを指定したフォルダに保存したいです。
1つ欲を言うと処理完了と同時に作業フォルダにあったメールは削除されるところまでいければ。。。
さらにもう一つだけ欲を言うと保存されたPDFを一括印刷できれば。。。

恐れいりますがよろしくお願いします。。

TV様、こんにちは。
ご質問の内容を実現するマクロを作成してみました。一応動作します。
ご要望の内容を厳密に実現すると、メールに添付されている複数のPDFファイルのうち、条件に合致したものが一部であった場合、そのメールは無くなってしまい条件に合致しないPDFを追跡できなくなります。
したがって、完全に削除ではなく、一応「削除済みアイテム」フォルダに残すほうが良いのではないかと判断しました。
保存したPDFの一括印刷はWindows標準の一括印刷機能を利用したほうが良いでしょう。

<現行>



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




<要望内容>


lTxt = InputBox("ファイル名に含まれる文言を指定してください。", "文言指定", "ほげほげ")
If lTxt = "" Then GoTo p_exit

'選択されたメールの添付ファイルを保存
For Each oSel In myOlSel
i = i + 1
ret = SetWindowText(hWnd, oSel & "(" & i & "/" & myOlSel.Count & ")" & "を処理中...")

JokenFlg = False
For Each oF In oSel.Attachments
If oF.DisplayName Like "*" & lTxt & "*" Then
oF.SaveAsFile cDir & "\" & oF.DisplayName
JokenFlg = True
End If
Next

If JokenFlg = True Then
oSel.Delete
End If
Next




コメントを書く

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

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