Outlook Save Attachment: Filename_yyyymmdd.extension

[davidlimcg23]

i bumped onto this simple save attachment code for outlook.

however, with newer updates for Outlook, Rules will not work on script.

How can this code run on-demand, or via a button?


purpose is simple: to extract attachment and append the receivedtime datecode.

thanks!


Public Sub saveAttachtoDisk(itm As Outlook.MailItem) Dim objAtt As Outlook.Attachment
Dim saveFolder As String
saveFolder = "C:\PathToDirectory\"
Dim dateFormat As String
dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ")
For Each objAtt In itm.Attachments
objAtt.SaveAsFile saveFolder & "\" & dateFormat & objAtt.DisplayName
Next
End Sub

[gmayor]

Rules will still work with scripts but you need to change a registry entry. If the value name is missing, you will have to create it.

Registry value.


Key: HKEY_CURRENT_USER\Software\Microsoft\Office\<version>\Outlook\Security
Value name: EnableUnsafeClientMailRules
Value type: REG_DWORD
Value: 1

where <version> is the Office version number e.g. 16.0

If you are not comfortable editing the registry, the following macro will effect the change


Sub ToggleOutlookScripts()
Dim wshShell As Object
Dim RegKey As String
Dim rKeyWord As String
Dim wVer As String
Set wshShell = CreateObject("WScript.Shell")
wVer = Val(Application.Version) & ".0"
Start:
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\" & wVer & "\Outlook\Security\"
On Error Resume Next
'The registry key does not exist
rKeyWord = wshShell.RegRead(RegKey & "EnableUnsafeClientMailRules")
If rKeyWord = "" Then
wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 1, "REG_DWORD" 'set it at zero
GoTo Start: 'and read it again
End If
If rKeyWord = 1 Then
wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 0, "REG_DWORD"
MsgBox "Unsafe Client Mail Rules disabled", vbInformation, "Scripts"
Else
wshShell.RegWrite RegKey & "EnableUnsafeClientMailRules", 1, "REG_DWORD"
MsgBox "Unsafe Client Mail Rules enabled", vbInformation, "Scripts"
End If
lbl_Exit:
Exit Sub
End Sub

[davidlimcg23]

thanks for the reply.

how can I make the script work standalone as macro?

this way, I can trigger it on-demand to any Outlook folder and extract all attachment within the outlook folder.

thanks again!

[gmayor]

Call it from another macro e.g. the following will extract from the current message.


Sub GetMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
saveAttachtoDisk olMsg
lbl_Exit:
Exit Sub
End Sub

[davidlimcg23]

Call it from another macro e.g. the following will extract from the current message.


Sub GetMsg()
Dim olMsg As MailItem
On Error Resume Next
Set olMsg = ActiveExplorer.Selection.Item(1)
saveAttachtoDisk olMsg
lbl_Exit:
Exit Sub
End Sub

thanks.

can it be tweaked to extract from whole Outlook folder?

just tested the above, it only work on 1 selected mail.

much thanks!

[gmayor]

I have covered this, and how to avoid duplicate names etc., several times in this forum. However the following should work with your code.


Sub ProcessAllMessagesInFolder()'Graham Mayor - https://www.gmayor.com - Last updated - 23 Oct 2019
Dim olItems As Outlook.items
Dim olItem As Object
Dim sPath As String
Set olItems = Session.PickFolder.items
For Each olItem In olItems
If TypeName(olItem) = "MailItem" Then
saveAttachtoDisk olItem
End If
DoEvents
Next olItem
lbl_Exit:
Set olItem = Nothing
Set olItems = Nothing
Exit Sub
End Sub

[davidlimcg23]

thanks, very much appreciate your help.