'アクティブウィンドウハンドルを取得する

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