Download Attachments from outlook

[vmjan02]

I just want to give a path to download the attachments, but no success,

It is now a hell of the code. is always opening the browser folder which should not be the case. it should directly download the attachments in strPath.
"strPath" its not working,


Code



strPath = "E:\Performance Report Automation\Daily Reports"
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")

Set objFolder = objFSO.getfolder(strPath)


If Err.Number <> 0 Then
MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
Err.Description & ".", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If

If objFolder Is Nothing Then
strFolderPath = ""
blnIsEnd = True
GoTo PROC_EXIT
Else
strFolderPath = CGPath(objFolder.Self.Path)

' /* Go through each item in the selection. */
For Each objItem In selItems
lCountEachItem = objItem.Attachments.Count

' /* If the current item contains attachments. */
If lCountEachItem > 0 Then
Set atmts = objItem.Attachments

' /* Go through each attachment in the current item. */
For Each atmt In atmts

' Get the full name of the current attachment.
strAtmtFullName = atmt.FileName

' Find the dot postion in atmtFullName.
intDotPosition = InStrRev(strAtmtFullName, ".")

' Get the name.
strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
' Get the file extension.
strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
' Get the full saving path of the current attachment.
strAtmtPath = strFolderPath & atmt.FileName



' /* If the length of the saving path is not larger than 260 characters.*/
If Len(strAtmtPath) <= MAX_PATH Then
' True: This attachment can be saved.
blnIsSave = True

' /* Loop until getting the file name which does not exist in the folder. */
Do While objFSO.FileExists(strAtmtPath)
strAtmtNameTemp = strAtmtName(0) & _
Format(Now, "_mmddhhmmss") & _
Format(Timer * 1000 Mod 1000, "000")
strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)

' /* If the length of the saving path is over 260 characters.*/
If Len(strAtmtPath) > MAX_PATH Then
lCountEachItem = lCountEachItem - 1
' False: This attachment cannot be saved.
blnIsSave = False
Exit Do
End If
Loop

' /* Save the current attachment if it is a valid file name. */
If blnIsSave Then atmt.SaveAsFile strAtmtPath
Else
lCountEachItem = lCountEachItem - 1
End If
Next
End If

' Count the number of attachments in all Outlook items.
lCountAllItems = lCountAllItems + lCountEachItem
Next
End If

 

[sijpie]

Holy cow, vmjan02, you have posted 480 times on this forum, and you still don't use code tags! See below in blue/red how to do these or use the code button on the toolbar.

Don't know why it comes up with the saveas box unless there is something wrong with the file types.

There is some alternative code here:
https://www.slipstick.com/developer/code-samples/save-rename-outlook-email-attachments/