Dauren
10-30-2014, 03:34 AM
Hi!
I have found macros for Outlook to auto save attachments on disk C:\ from Outlook emails, but it doesn't work.
Seems like this code was for early version of Outlook (I use 2013).
Please help me to adapt this code for Outlook 2013:
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 dblCount, dblLoop As Double
' 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..."
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set fld = GetFolder("Index\Omniture")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo ExitSub
' Check each selected item for attachments.
' If attachments exist, save them to the Macro
' folder on the Desktop.
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
strName = Left$(strName, Len(strName) - 4) '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
'''''''''''''''''''
' 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
''''''''''''''''''''''''''''''''''''''''
Next dblLoop
End If
100
Next
ExitSub:
Set objAttachments = Nothing
Set objMessage = Nothing
Set objHighlighted = Nothing
Set objOutlook = Nothing
End Sub
' This entire section of code was provided to me by Sue.
' This is NOT my work and I am NOT taking credit for it.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFolder(FolderPath)
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim aFolders
Dim fldr
Dim i
Dim objNS
On Error Resume Next
strFolderPath = Replace(FolderPath, "/", "\")
aFolders = Split(FolderPath, "\")
'get the Outlook objects
' use intrinsic Application object in form script
Set objNS = Application.GetNamespace("MAPI")
'set the root folder
Set fldr = objNS.Folders(aFolders(0))
'loop through the array to get the subfolder
'loop is skipped when there is only one element in the array
For i = 1 To UBound(aFolders)
Set fldr = fldr.Folders(aFolders(i))
'check for errors
If Err <> 0 Then Exit Function
Next
Set GetFolder = fldr
' dereference objects
Set objNS = Nothing
End Function
Sub Save_att()
End Sub
I have found macros for Outlook to auto save attachments on disk C:\ from Outlook emails, but it doesn't work.
Seems like this code was for early version of Outlook (I use 2013).
Please help me to adapt this code for Outlook 2013:
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 dblCount, dblLoop As Double
' 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..."
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Set fld = GetFolder("Index\Omniture")
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
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"
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
On Error GoTo ExitSub
' Check each selected item for attachments.
' If attachments exist, save them to the Macro
' folder on the Desktop.
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
strName = Left$(strName, Len(strName) - 4) '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
'''''''''''''''''''
' 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
''''''''''''''''''''''''''''''''''''''''
Next dblLoop
End If
100
Next
ExitSub:
Set objAttachments = Nothing
Set objMessage = Nothing
Set objHighlighted = Nothing
Set objOutlook = Nothing
End Sub
' This entire section of code was provided to me by Sue.
' This is NOT my work and I am NOT taking credit for it.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function GetFolder(FolderPath)
' folder path needs to be something like
' "Public Folders\All Public Folders\Company\Sales"
Dim aFolders
Dim fldr
Dim i
Dim objNS
On Error Resume Next
strFolderPath = Replace(FolderPath, "/", "\")
aFolders = Split(FolderPath, "\")
'get the Outlook objects
' use intrinsic Application object in form script
Set objNS = Application.GetNamespace("MAPI")
'set the root folder
Set fldr = objNS.Folders(aFolders(0))
'loop through the array to get the subfolder
'loop is skipped when there is only one element in the array
For i = 1 To UBound(aFolders)
Set fldr = fldr.Folders(aFolders(i))
'check for errors
If Err <> 0 Then Exit Function
Next
Set GetFolder = fldr
' dereference objects
Set objNS = Nothing
End Function
Sub Save_att()
End Sub