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

[VBA]
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[/VBA]


HTH

[Nosstech]

Thanks! I'll give this a try