There is a lot to fix here. Once you get this working you can delete any unwanted comments. The green lines.
Option Explicit ' <--- Important
Sub SaveAllAttachments()
' In the original code, Sub Save_att() was likely what passed objitem
' to Sub SaveAllAttachments(objitem As mailitem)
Dim objMessage As Object
Dim objHighlighted As Outlook.Items
Dim objAttachments As Outlook.Attachments
'Dim strName, strLocation As String
Dim strName As String, strLocation As String
'Dim dblCount, dblLoop As Double
Dim dblCount As Double, dblLoop As Double
Dim Fld As Folder ' *** New line due to Option Explicit
Dim strID As String ' *** New line due to Option Explicit
Dim strExt As String ' *** New line due to Option Explicit
' If you are using this code you will need to edit this
' line so that it matches the location within outlook
' of the folder you intend to scan
' NOTE!! Only edit the "Personal Folders\Processing..."
On Error Resume Next
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set Fld = GetFolder("Index\Omniture")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo 0
If Fld Is Nothing Then
MsgBox "Invalid Outlook folder location passed to GetFolder.", , "SaveAllAttachments"
GoTo ExitSub
End If
On Error GoTo ErrorHandler
' If you do not see the errors then
' "I have found macros for Outlook to auto save attachments
' on disk C:\ from Outlook emails, but it doesn't work."
Set objHighlighted = Fld.Items ' Tell it what to scan
' This is the location of the folder I want to save my attachments to
' You will most likely need to edit this to match the location of
' the folder you intend to save your attachments in.
' NOTE! Only edit C:\Documents and Settings\Administrator\Desktop\macro\
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
strLocation = "C:\Omniture"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' New line ***
If Right(strLocation, Len(strLocation)) <> "\" Then strLocation = strLocation & "\"
' Check each selected item for attachments.
' If attachments exist, save them to strLocation
For Each objMessage In objHighlighted ' For each email in the folder
If objMessage.Class = olMail Then ' ONLY scan emails!!
Set objAttachments = objMessage.Attachments
' Now to set my loop to the amount of attachments
' on the current email the script is processing.
dblCount = objAttachments.count
If dblCount <= 0 Then GoTo 100 ' If no attachments exsist
' go to the next email.
' I know this part looks weird...But If I counted
' upwards, the script was not recognizing every
' email and was skipping like half of them. By
' counting downwards, this problem is resolved.
' Thanks to Slovaktech.com for solving this one.
For dblLoop = dblCount To 1 Step -1
' This will be appended to the file name of each attachment to insure
' that there are no duplicates, and therefor nothing gets overwritten
strID = " from " & Format(Date, "mm-dd-yy") 'Append the Date
strID = strID & " at " & Format(time, "hh`mm`ss AMPM") 'Append the Time
' These lines are going to retrieve the name of the
' attachment, attach the strID to it to insure it is
' a unique name, and then insure that the file
' extension is appended to the end of the file name.
strName = objAttachments.item(dblLoop).FileName 'Get attachment name
'strExt = Right$(strName, 4) 'Store file Extension
' New line *** The extension including the period can be either 4 or 5 characters long
strExt = Mid$(strName, InStrRev(strName, ".")) 'Store file Extension including period
'strName = Left$(strName, Len(strName) - 4) 'Remove file Extension
' Revised line ***
strName = Left$(strName, Len(strName) - Len(strExt)) 'Remove file Extension
strName = strName & strID & strExt 'Reattach Extension
' Tell the script where to save it and
' what to call it
strName = strLocation & strName 'Put it all together
' Save the attachment as a file.
objAttachments.item(dblLoop).SaveAsFile strName 'Save the attachment
' This next line DELETES the email completly.
' If you do not wish to delete the email
' change this line to read objMessage.Save
'''''''''''''''''''
'objMessage.Save ' *** Not needed. objMessage was not changed
'''''''''''''''''''
' This section of code is optional. It puts a 1 second
' delay between file saves so that my strID is unique
' for EVERY file. I do this because the script does
' not confirm overwrites and this would be an issue for
' the client I am writing this for. If this is not an
' issue for you, just delete the entire section or
' simply comment it out.
''''''''''''''''''''''''''''''''''''''''
'Dim PauseTime, Start, Finish, TotalTime
'PauseTime = 1
'Start = Timer
'Do While Timer < Start + PauseTime
'Loop
'Finish = Timer
Dim PauseTime, Start
PauseTime = 1 / 86400 ' ( 1 day divided by 86400 seconds in a day = 1 second)
Start = Now
Do While Now < Start + PauseTime
Loop
''''''''''''''''''''''''''''''''''''''''
Next dblLoop
End If
100
Next
GoTo ExitSub
ErrorHandler:
MsgBox "ErrorHandler:" & vbCr & vbCr _
& "Error Code: " & Err.Number & vbCr & vbCr & Err.Description, , "SaveAllAttachments"
Err.Clear
ExitSub:
Set objAttachments = Nothing
Set objMessage = Nothing
Set objHighlighted = Nothing
'Set objOutlook = Nothing
End Sub