a-Column

【VB】Outlookで選択した複数メールの添付を保存する


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


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

Last Update : 2011年11月24日 (木) 18:44