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.