MrsGarrett
04-21-2014, 12:30 PM
I have taken some code from a book that is supposed to save email attachements to a folder.
When I try to run it I get "Compile Error: Variable not defined" and it highlights the code that is supposed to create a target directory object that is used for saving attachements:
Set fld = fso.getfolder (SelectFolder) Do I need to fill in any of this with my own information?
Option Explicit
Public Sub SaveAttachments()
'Outlook Application Objects Declaration
Dim objApp As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim itemAttc As Outlook.Attachment
'FilesystemObject Objects Declaration
Dim fso As Object 'FileSystemObject
Dim fld As Object 'Folder
Dim fil As Object 'File
Dim i As Long 'Counter
'Array variable to store file name and extension
Dim strFileName() As String
On Error GoTo ErrHandler
'create filesystemObject object
Set fso = CreateObject("Scripting.FilesystemObject")
'Create target directory object that is used for saving attachements
Set fld = fso.getfolder(SelectFolder)
'set objApp object
Set objApp = Outlook.Application
'set source folder as the currently activated folder
Set objFolder = objApp.ActiveExplorer.CurrentFolder
'confirmation
If MsgBox("Do you want to extract all attached items " & "in " & objFolder.Name & "and save into " & fld.Path & " directory?", _
vbYesNo + vbQuestion, "Confirmation") = vbNo _
Then GoTo ErrHandler
'Explore all mail items in selected folder
For Each objItem In objFolder.Items
'if item is mail object then continue processing item
If objItem.Class = olMail Then
'explore all attachments in email message
For Each itemAttc In objItem.Attachments
'Increase counter for attachment count
i = i + 1
'Retrieve file name and extension
'Calls ExplodeFileName custom function
strFileName = ExplodeFileName(itemAttc.FileName)
'Create new file name if the same file is already existing in folder
'Simply adds _x at the end of the file
'x is the incrementing number
strFileName = CreateFileName(strFileName, fso, fld)
'Finally, save attachment as file by given path
itemAttc.SaveAsFile fld.Path & "\" & strFileName(0) & strFileName(1)
Next itemAttc
End If
Next objItem
'inform user about completion and saved number of attachement
MsgBox i & " attachments have been successfully saved in " & fld.Path
exitsub:
'release object variables and memory
Set fso = Nothing
Set objApp = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case 76 'target directory doesn't exist
MsgBox "Selected directory doesn't exist.", vbOKOnly + vbExclamation, "Error"
Case Is <> 0 'another critical error
MsgBox Err.Number & "-" & Err.Description, vbOKOnly + vbExclamation, "Error"
End Select
Resume exitsub
End Sub
Private Function ExplodeFileName(strFileName As String)
'variable declaration
Dim dotpos As Integer
Dim strArr(1) As String
'Find the last dot position to parse strFileName
'InStrRev function is being used to start from the end of string
dotpos = InStrRev(strFileName, ".")
If dotpos = 0 Then
'there is no extension
strArr(0) = strFileName
strArr(1) = ""
Else
'parse file name
strArr(0) = Left(strFileName, dotpos - 1)
'parse file extension
strArr(1) = Right(strFileName.Len(strFileName) - dotpos + 1)
End If
'return an array
'first item is the file name
'Second item is the file extension
ExplodeFileName = strArr
End Function
Private Function CreaeFileName(strFileName() As String, fso As Object, fld As Object)
'variable declaration
Dim strSuffix As String
Dim intSuffix As Integer
Dim strFinalFileName(1) As String
'Incremement intSuffix until file is not existing
'FileExists method returns True if there is a file named with parameter string
Do Until Not fso.FixExists(fld.Path & "\" & strFileName(0) & strSuffix & strFileName(1))
intSuffix = intSuffix + 1
'create file name suffix
strSuffix = "_" & CStr(intSuffix)
Loop
strFinalFileName(0) = strFileName(0) & strSuffix
strFinalFileName(1) = strFileName(1)
'Return an array
'first item is the final file name
'Second item is the file extension
CreateFileName = strFinalFileName
End Function
End Function
When I try to run it I get "Compile Error: Variable not defined" and it highlights the code that is supposed to create a target directory object that is used for saving attachements:
Set fld = fso.getfolder (SelectFolder) Do I need to fill in any of this with my own information?
Option Explicit
Public Sub SaveAttachments()
'Outlook Application Objects Declaration
Dim objApp As Outlook.Application
Dim objFolder As Outlook.MAPIFolder
Dim objItem As Object
Dim itemAttc As Outlook.Attachment
'FilesystemObject Objects Declaration
Dim fso As Object 'FileSystemObject
Dim fld As Object 'Folder
Dim fil As Object 'File
Dim i As Long 'Counter
'Array variable to store file name and extension
Dim strFileName() As String
On Error GoTo ErrHandler
'create filesystemObject object
Set fso = CreateObject("Scripting.FilesystemObject")
'Create target directory object that is used for saving attachements
Set fld = fso.getfolder(SelectFolder)
'set objApp object
Set objApp = Outlook.Application
'set source folder as the currently activated folder
Set objFolder = objApp.ActiveExplorer.CurrentFolder
'confirmation
If MsgBox("Do you want to extract all attached items " & "in " & objFolder.Name & "and save into " & fld.Path & " directory?", _
vbYesNo + vbQuestion, "Confirmation") = vbNo _
Then GoTo ErrHandler
'Explore all mail items in selected folder
For Each objItem In objFolder.Items
'if item is mail object then continue processing item
If objItem.Class = olMail Then
'explore all attachments in email message
For Each itemAttc In objItem.Attachments
'Increase counter for attachment count
i = i + 1
'Retrieve file name and extension
'Calls ExplodeFileName custom function
strFileName = ExplodeFileName(itemAttc.FileName)
'Create new file name if the same file is already existing in folder
'Simply adds _x at the end of the file
'x is the incrementing number
strFileName = CreateFileName(strFileName, fso, fld)
'Finally, save attachment as file by given path
itemAttc.SaveAsFile fld.Path & "\" & strFileName(0) & strFileName(1)
Next itemAttc
End If
Next objItem
'inform user about completion and saved number of attachement
MsgBox i & " attachments have been successfully saved in " & fld.Path
exitsub:
'release object variables and memory
Set fso = Nothing
Set objApp = Nothing
Exit Sub
ErrHandler:
Select Case Err.Number
Case 76 'target directory doesn't exist
MsgBox "Selected directory doesn't exist.", vbOKOnly + vbExclamation, "Error"
Case Is <> 0 'another critical error
MsgBox Err.Number & "-" & Err.Description, vbOKOnly + vbExclamation, "Error"
End Select
Resume exitsub
End Sub
Private Function ExplodeFileName(strFileName As String)
'variable declaration
Dim dotpos As Integer
Dim strArr(1) As String
'Find the last dot position to parse strFileName
'InStrRev function is being used to start from the end of string
dotpos = InStrRev(strFileName, ".")
If dotpos = 0 Then
'there is no extension
strArr(0) = strFileName
strArr(1) = ""
Else
'parse file name
strArr(0) = Left(strFileName, dotpos - 1)
'parse file extension
strArr(1) = Right(strFileName.Len(strFileName) - dotpos + 1)
End If
'return an array
'first item is the file name
'Second item is the file extension
ExplodeFileName = strArr
End Function
Private Function CreaeFileName(strFileName() As String, fso As Object, fld As Object)
'variable declaration
Dim strSuffix As String
Dim intSuffix As Integer
Dim strFinalFileName(1) As String
'Incremement intSuffix until file is not existing
'FileExists method returns True if there is a file named with parameter string
Do Until Not fso.FixExists(fld.Path & "\" & strFileName(0) & strSuffix & strFileName(1))
intSuffix = intSuffix + 1
'create file name suffix
strSuffix = "_" & CStr(intSuffix)
Loop
strFinalFileName(0) = strFileName(0) & strSuffix
strFinalFileName(1) = strFileName(1)
'Return an array
'first item is the final file name
'Second item is the file extension
CreateFileName = strFinalFileName
End Function
End Function