CODEWITHSUNDEEP
vbaoutlook
Michael
Michael

Reputation: 13

How to create customized subfolders and save email attachments to those folders which are stored on my PC?

Currently, the code below which I got from (Save attachments from multiple selected items in Outlook (VBA)) takes the emails I select, asks me where to save the email attachments and saves the attachments as named in the emails to the folder I selected.

The problem is, if I select multiple emails, there is no way of telling which email the attachments are associated to.

Would it be possible to have it so when I select where to save the attachments that the script creates a sub folder for each email and then puts the attachments in that folder? I'd like to use the SenderName for each sub folder name and add the date to the end of it? Example, "SubFolderXYZ_04-30-2018".

Also, is there a way to make it so that the date on the sub-folder matches the date that the email was received, instead of "today's" date?

Option Explicit

If VBA7 Then
    Private lHwnd As LongPtr
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As LongPtr
Else
    Private lHwnd As Long    
    Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
End If

' The class name of Outlook window.  
Private Const olAppCLSN As String = "rctrl_renwnd32"
' Windows desktop - the virtual folder that is the root of the namespace.  
Private Const CSIDL_DESKTOP = &H0
' Only return file system directories. If the user selects folders that are not part of the file system, the OK button is grayed.  
Private Const BIF_RETURNONLYFSDIRS = &H1
' Do not include network folders below the domain level in the dialog box's tree view control.  
Private Const BIF_DONTGOBELOWDOMAIN = &H2
' The maximum length for a path is 260 characters.  
Private Const MAX_PATH = 260

'  Returns the number of attachements in the selection.  
Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO              As Object       ' Computer's file system object.  
Dim objShell            As Object       ' Windows Shell application object.  
Dim objFolder           As Object       ' The selected folder object from Browse for Folder dialog box.  
Dim objItem             As Object       ' A specific member of a Collection object either by position or by key.  
Dim selItems            As Selection    ' A collection of Outlook item objects in a folder.  
Dim atmt                As Attachment   ' A document or link to a document contained in an Outlook item.  
Dim strAtmtPath         As String       ' The full saving path of the attachment.  
Dim strAtmtFullName     As String       ' The full name of an attachment.  
Dim strAtmtName(1)      As String       ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.  
Dim strAtmtNameTemp     As String       ' To save a temporary attachment file name.  
Dim intDotPosition      As Integer      ' The dot position in an attachment name.  
Dim atmts               As Attachments  ' A set of Attachment objects that represent the attachments in an Outlook item.  
Dim lCountEachItem      As Long         ' The number of attachments in each Outlook item.  
Dim lCountAllItems      As Long         ' The number of attachments in all Outlook items.  
Dim strFolderPath       As String       ' The selected folder path.  
Dim blnIsEnd            As Boolean      ' End all code execution.  
Dim blnIsSave           As Boolean      ' Consider if it is need to save.  

blnIsEnd = False
blnIsSave = False
lCountAllItems = 0

On Error Resume Next

Set selItems = ActiveExplorer.Selection

If Err.Number = 0 Then

    ' Get the handle of Outlook window.  
    lHwnd = FindWindow(olAppCLSN, vbNullString)

    If lHwnd <> 0 Then

        ' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */  
        Set objShell = CreateObject("Shell.Application")
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
                                                 BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)

        ' /* Failed to create the Shell application. */  
        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, "_mm-dd-yyyy")
                                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
    Else
        MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
        blnIsEnd = True
        GoTo PROC_EXIT
    End If

' /* For run-time error:  
'    The Explorer has been closed and cannot be used for further operations.  
'    Review your code and restart Outlook. */  
Else
    MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
    blnIsEnd = True
End If

PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems

' /* Release memory. */  
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (atmt Is Nothing) Then Set atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing

' /* End all code execution if the value of blnIsEnd is True. */  
If blnIsEnd Then End
End Function

' Convert general path.  
Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
End Function

' Run this macro for saving attachments.  
Public Sub ExecuteSaving()
    Dim lNum As Long

    lNum = SaveAttachmentsFromSelection

    If lNum > 0 Then
        MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
    Else
        MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
    End If
End Sub

Upvotes: 0

Views: 172

Answers (1)

0m3r
0m3r

Reputation: 12499

To get the date email was received work with MailItem.ReceivedTime Property (Outlook) then format it like this Format(objItem.ReceivedTime, "DD-MM-YYYY")

for the folder use basic function that will check if folder exist else create one using MailItem.SenderName Property (Outlook)

Example

Private Function CreateDir(strFolderPath As String)
    Dim Elm As Variant
    Dim CheckPath As String

    CheckPath = ""
    For Each Elm In Split(strFolderPath, "\")
        CheckPath = CheckPath & Elm & "\"

        Debug.Print CheckPath & " Folder Exist"

        If Len(Dir(CheckPath, vbDirectory)) = 0 Then
            MkDir CheckPath
            Debug.Print CheckPath & " Folder Created"
        End If
    Next
End Function

In your code make these changes

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

    Dim ResetPath As String
        ResetPath = strFolderPath

    strFolderPath = strFolderPath & objItem.SenderName & "_" & _
                             Format(objItem.ReceivedTime, "DD-MM-YYYY")

    CreateDir strFolderPath

    lCountEachItem = objItem.Attachments.Count

And this should be

strAtmtPath = strFolderPath & "\" & atmt.FileName

And the following 

    ' Count the number of attachments in all Outlook items.
    lCountAllItems = lCountAllItems + lCountEachItem
    strFolderPath = ResetPath ' reset
Next

Upvotes: 0

Related Questions