Outlook Save Attachment: Filename_yyyymmdd.extension

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!

Code:

---

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

---

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

Code:

---

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

---

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!

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

Code:

---

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

---

Quote:

---

Originally Posted by gmayor

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

Code:

---

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!

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

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

---

thanks, very much appreciate your help.