保存済みmsgファイルから添付ファイルの取り出し
昔作ったシナリオで、保存済みのmsgファイル(メールファイル)から添付のExcelを保存するのに、
・Outlookで開き
・画像マッチングで左ボタン
・エミュレーションで名前を付けて保存
・Outlook終了
を行っていましたが、本日、不具合があり、直そうと思ったのですが、私のPC環境は画面が多く、解像度もバラバラで
画像マッチングがうまく設定できず、こんな不安定なら、そこを作り直そうとライブラリを作成しましたのでご紹介します。
ただ、もし、既にプチライブラリとかスマートライブラリにmsgファイルから添付を取り出すものがあれば、教えてください。
私の作成したものは、下記のとおり簡易的なものです。
Option Explicit
Dim fso
Dim SaveFolderPath
Dim msg
Dim Mydic
Dim olApp
Dim itm
Dim atc
Dim fn
msg = !msgファイル!
SaveFolderPath = !保存フォルダ!
Set fso = CreateObject("Scripting.FileSystemObject")
Set Mydic = CreateObject("Scripting.Dictionary")
Set olApp = CreateObject("Outlook.Application")
Set itm = olApp.GetNamespace("MAPI").OpenSharedItem(msg)
If LCase(TypeName(itm)) = "mailitem" Then
With fso
For Each atc In itm.Attachments
fn = SaveFolderPath & "\" & atc.Filename
If .FileExists(fn) = True Then
.DeleteFile (fn)
End If
Mydic.Add atc.Filename, .getFileName(msg)
atc.SaveAsFile fn
Next
End With
End If
olApp.Quit
Set itm = Nothing
Set olApp = Nothing
Set Mydic = Nothing
Set fso = Nothing