Solved: Saving Multiple Email Attachments to a File Folder

[Nosstech]

Hi All,
I have to save attachments from Outloook 2007 to a folder located in "C:\Compassess\". Right now the code only saves the first attached file. How do I save multiple attachments?
Thanks for your help
-B

' Declare necessary API routines:
Declare Function FindWindow Lib "user32" Alias _
"FindWindowA" (ByVal lpClassName As String, _
ByVal lpWindowName As Long) As Long

Declare Function SendMessage Lib "user32" Alias _
"SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Sub OpenAllAttachments()
Dim intitemcnt As Integer
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
'Dim myXLApp As Excel.Application
Dim strFN As String
On Error Resume Next
' Clear all old isis files in Temp Folder
Set fs = CreateObject("Scripting.FileSystemObject")
'fs.DeleteFile "C:\SelfAssessFiles\*.xls", True
Dim ThisWorkbook As Excel.Application
'****** UPDATE THIS FILEPATH ******
'fs.DeleteFile "C:\SelfAssessFiles\*.xls", True
' Set MSOutlook application variables
Set myNameSpace = Application.GetNamespace("MAPI")
Set myOlExp = Application.ActiveExplorer
Set myOlSel = myOlExp.Selection

For x = 1 To myOlSel.Count ' Run for each mail item selected
Set myItem = myOlSel.Item(x)
Set myopenattach = myItem.Attachments.Item(1)
here:
strFN = "C:\SelfAssessFiles\Assessment " & x & ".xls" ' saved file location
On Error Resume Next
Err.Clear ' Clear Err object in case error occurred
myopenattach.SaveAsFile strFN

'Set ThisWorkbook = ActiveWorkbook
Excel.Application.Quit
' ThisWorkbook.Close savechanges:=False
If Err.Number = -2147467259 Then

x = x + 1
Err.Clear
GoTo here:
End If
Set MyXL = GetObject(, "Excel.Application")
If Err.Number <> 0 Then
ExcelWasNotRunning = True
' Clear Err object in case error occurred.
Err.Clear
Set myXLApp = CreateObject("Excel.Application")
Else
' Check to see if Excel is already open
Set myXLApp = GetObject(, "Excel.Application")
End If
' activate Excel
myXLApp.Visible = True
' open selected file(s)
myXLApp.Workbooks.Open FileName:=strFN
myItem.UnRead = False
myXLApp.Quit
Next x
myXLApp.DisplayAlerts = True
myXLApp.Quit
Set myXLApp = Nothing
'OpenWB
'Excel.Application.Workbooks.Open ("C:\Documents and Settings\kcbln00\My Documents\Projects\Competency Assessment\Self Assess Data.xls")
End Sub
Sub DetectExcel()
' Procedure checks to see if Excel is running and registers it.
Const WM_USER = 1024
Dim hWnd As Long
' If Excel is running this API call returns its handle.
hWnd = FindWindow("XLMAIN", 0)
If hWnd = 0 Then ' 0 means Excel not running.
Exit Sub
Else
' Excel is running so use the SendMessage API
' function to enter it in the Running Object Table.
SendMessage hWnd, WM_USER + 18, 0, 0
End If
End Sub

[JP2112]

Hi All,
I have to save attachments from Outloook 2007 to a folder located in "C:\Compassess\". Right now the code only saves the first attached file. How do I save multiple attachments?
Thanks for your help
-B

Set an object reference to the message's Attachment collection, then iterate through it and call the SaveAsFile method on each one. For example


Dim attach as Outlook.Attachments
Set attach = myItem.Attachments

Dim i As Long
For i = 1 to attach.Count
attach.item(i).SaveAsFile "your filename"
Next i


HTH

[Nosstech]

Thanks! I'll give this a try