Consulting

Results 1 to 7 of 7

Thread: Outlook Save Attachment: Filename_yyyymmdd.extension

  1. #1

    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!

    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

  2. #2
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  3. #3
    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!

  4. #4
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  5. #5
    Quote Originally Posted by gmayor View Post
    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!

  6. #6
    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
    Graham Mayor - MS MVP (Word) 2002-2019
    Visit my web site for more programming tips and ready made processes
    http://www.gmayor.com

  7. #7
    thanks, very much appreciate your help.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •