Save Attachments To a Folder

[nathandavies]

Hi All,
I have tried to create some code to save email attachments to my server, but seem to be having an issue. I can select the folders through 2 input boxes but then it creates an error 91. i have highlight my code as to where the error is for your assistance

Option ExplicitPrivate Const strRoot As String = "\\NEWBENSON\Projects\drawings\"
Private Function GetPath() As String
    Dim FSO As Object
    Dim Folder As Object
    Dim subFolder As Object
    Dim strPath As String
    Dim bPath As Boolean
Start:
    strPath = InputBox("Enter Project Number.")
    If strPath = "" Then GoTo lbl_Exit
    If Not Len(strPath) = 5 And Not IsNumeric(Right(strPath, 4)) Then
        MsgBox "Enter a Letter and 4 digits!"
GoTo Start:
    End If
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Folder = FSO.GetFolder(strRoot)
    For Each subFolder In Folder.SubFolders
         'Debug.Print subFolder & vbTab & strRoot & strPath
        If InStr(1, CStr(subFolder), UCase(strPath)) > 0 Then
            strPath = CStr(subFolder)
            bPath = True
            Exit For
        End If
    Next
    If Not bPath Then strPath = ""
lbl_Exit:
    GetPath = strPath
    Exit Function
End Function


Public Sub SaveAttachments()
Dim fname As String
Dim fPath1 As String, fPath2 As String
Dim strPath As String
Const fRootPath As String = "\\NEWBENSON\Projects\drawings\"
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String


    fPath1 = InputBox("Enter the customer folder name in which to save the attachments." & vbCr & _
    "The path will be created if it doesn't exist.", _
    "Save Message")
    fPath1 = Replace(fPath1, "\", "")
     
    fPath2 = InputBox("Enter the project name and number.", _
    "Save Message")
    fPath2 = Replace(fPath2, "\", "")
     
    strPath = fRootPath & fPath1 & "\" & fPath2
    CreateFolders strPath
    CreateFolders strPath & "\Documents\Documents Received"
    
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")


' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection


' Check each selected item for attachments. If attachments exist,
' save them to the strFolderPath folder and strip them from the item.
For Each objMsg In objSelection
   
            ' Save attachment before deleting from item.
            ' Get the file name.
            strFile = objAttachments.Item(i).FileName 'error is created here!!


            ' Combine with the path to the Temp folder.
            strFile = strPath & strFile


            ' Save the attachment as a file.
            objAttachments.Item(i).SaveAsFile strFile


          
 
        objMsg.Save
    
Next


ExitSub:


Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub



Private Sub CreateFolders(strPath As String)
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
        Exit Sub
End Sub


 Private Sub CreateFolders1(strPath As String)
    Dim oFSO As Object
    Dim lngPathSep As Long
    Dim lngPS As Long
    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
    lngPathSep = InStr(3, strPath, "\")
    If lngPathSep = 0 Then GoTo lbl_Exit
    Set oFSO = CreateObject("Scripting.FileSystemObject")
    Do
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
        If lngPathSep = 0 Then Exit Do
        If Len(Dir(Left(strPath, lngPathSep), vbDirectory)) = 0 Then Exit Do
    Loop
    Do Until lngPathSep = 0
        If Not oFSO.FolderExists(Left(strPath, lngPathSep)) Then
            oFSO.CreateFolder Left(strPath, lngPathSep)
        End If
        lngPS = lngPathSep
        lngPathSep = InStr(lngPS + 1, strPath, "\")
    Loop
lbl_Exit:
    Set oFSO = Nothing
        Exit Sub
End Sub

.

[gmayor]

See your other related thread.