Outlook extract zip file and download Monty

[Monty]

Hello Everyone,

Happy to share some interesting stuff which is recently implemented by using VBA. How to extract attached email and save in our drive.

Apologies for any confusion. Here's the complete and combined code for downloading the zip attachment from Outlook and unzipping its contents:

#If VBA7 Then
    Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr
#Else
    Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
#End If

Sub UnzipAttachmentFromOutlook()
    Dim objOutlook As Object ' Outlook Application
    Dim objNamespace As Object ' Outlook Namespace
    Dim objInbox As Object ' Outlook Inbox
    Dim objMailItem As Object ' Outlook Mail Item
    Dim objAttachment As Object ' Outlook Attachment
    Dim strAttachmentPath As String ' Path to save the downloaded zip file
    Dim strUnzipPath As String ' Path to save the unzipped contents
    Dim ShellApp As Object ' Shell Application to unzip
    Dim subjectKeyword As String ' Keyword to search in the email subject
    Dim senderFound As Boolean ' Flag to check if a matching email is found
    Dim currentDate As Date ' Current date
    Dim objItems As Object ' Collection of items in today's date
  
    ' Set the subject keyword to search for
    subjectKeyword = "XXX" ' Change this to the desired keyword
  
    ' Set the path to save the downloaded zip file
    strAttachmentPath = "C:\Path\To\DownloadedZip\" ' Change this to the desired path
  
    ' Set the path to save the unzipped contents
    strUnzipPath = "C:\Path\To\Unzip\" ' Change this to the desired path
  
    ' Get the current date
    currentDate = Date
  
    ' Initialize Outlook objects
    On Error Resume Next
    Set objOutlook = GetObject(, "Outlook.Application")
    If objOutlook Is Nothing Then
        Set objOutlook = CreateObject("Outlook.Application")
    End If
    On Error GoTo 0
  
    ' Get the Inbox folder
    Set objNamespace = objOutlook.GetNamespace("MAPI")
    Set objInbox = objNamespace.GetDefaultFolder(6) ' 6 is the olFolderInbox enumeration value
  
    ' Get today's date emails from Inbox using the Filter
    Set objItems = objInbox.Items.Restrict("[ReceivedTime] >= '" & Format(currentDate, "ddddd h:nn AMPM") & "' AND [ReceivedTime] < '" & Format(currentDate + 1, "ddddd h:nn AMPM") & "'")
  
    ' Loop through each email in today's date emails
    For Each objMailItem In objItems
        ' Check if the subject contains the specified keyword and the email has attachments
        If InStr(1, objMailItem.Subject, subjectKeyword, vbTextCompare) = 1 And objMailItem.Attachments.Count > 0 Then
            ' Assuming there's only one .zip attachment in the email
            For Each objAttachment In objMailItem.Attachments
                If Right(objAttachment.FileName, 4) = ".zip" Then
                    ' Save the .zip attachment to a temporary location
                    objAttachment.SaveAsFile strAttachmentPath & objAttachment.FileName
                    ' Set the flag to true indicating a matching email is found
                    senderFound = True
                    ' Exit the loop after processing the latest email
                    Exit For
                End If
            Next objAttachment
        End If
      
        ' Exit the loop if a matching email is found
        If senderFound Then Exit For
    Next objMailItem
  
    ' Release objects from memory
    Set objAttachment = Nothing
    Set objMailItem = Nothing
    Set objInbox = Nothing
    Set objNamespace = Nothing
    Set objOutlook = Nothing
  
    ' Notify the user about the process status
    If senderFound Then
        MsgBox "Zip file downloaded from the latest email with subject starting with ""XXX"" and received on the current date.", vbInformation

        ' Unzip the contents using ShellExecute
        Dim retVal As LongPtr
        retVal = ShellExecute(0, "Open", strAttachmentPath & objAttachment.FileName, vbNullString, strUnzipPath, vbNormalNoFocus)
      
        If retVal > 32 Then
            MsgBox "Unzip process completed for the latest email with subject starting with ""XXX"" and received on the current date.", vbInformation
        Else
            Dim errorMessage As String
            errorMessage = "Failed to unzip the folder. Error Code: " & CStr(retVal)
            MsgBox errorMessage, vbExclamation
        End If
      
        ' Clean up: delete the downloaded zip file
        Kill strAttachmentPath & objAttachment.FileName
    Else
        MsgBox "No matching email found with subject starting with ""XXX"" on the current date or the email does not contain a .zip attachment.", vbExclamation
    End If
  
    ' Release objects from memory
    Set ShellApp = Nothing
End Sub

If you encounter any issues or have further questions, please let me know, and I'll be happy to assist you further.

 

[Monty]

>>> use code - tags <<<

Sub MoveFilesWithSameFirst7CharsToNewFoldersAndRenameMasterFolder()
    Dim sourceFolderPath As String
    Dim targetFolderPath As String
    Dim masterFolderPath As String
    Dim fso As Object
    Dim sourceFolder As Object
    Dim file As Object
    Dim targetFolder As Object
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    Dim dayStr As String
    Dim monthStr As String
    Dim yearStr As String
   
    ' Set the source folder path where the files are currently located
    sourceFolderPath = "C:\SourceFolder\"
   
    ' Set the target folder path where new folders will be created to move the files
    targetFolderPath = "C:\TargetFolder\"
   
    ' Set the master folder path that you want to rename
    masterFolderPath = "C:\MasterFolder\"
   
    ' List of simple file extensions, separated by semicolon (;)
    Dim simpleFileExtensions As String
    simpleFileExtensions = "txt;csv;pdf;doc;xls;xlsx"
   
    ' Create a new FileSystemObject
    Set fso = CreateObject("Scripting.FileSystemObject")
   
    ' Get the source folder
    Set sourceFolder = fso.GetFolder(sourceFolderPath)
   
    ' Loop through each file in the source folder
    For Each file In sourceFolder.Files
        Dim fileName As String
        fileName = fso.GetFileName(file.Path)
       
        ' Check if the filename has at least 7 characters
        If Len(fileName) >= 7 Then
            ' Get the first 7 characters of the filename
            Dim key As String
            key = Left(fileName, 7)
           
            ' Check if the filename with the first 7 characters exists in the dictionary
            If dict.Exists(key) Then
                ' Use the existing folder with the same name
                Set targetFolder = dict(key)
            Else
                ' Create a new folder with the first 7 characters of the filename in the target folder
                Set targetFolder = fso.CreateFolder(targetFolderPath & key)
                ' Add the folder to the dictionary
                dict.Add key, targetFolder
            End If
           
            ' Move the file to the folder
            fso.MoveFile file.Path, targetFolder.Path & "\" & fileName
        End If
    Next file
   
    ' Get the day, month, and year components
    dayStr = Format(Now, "d")
    monthStr = Format(Now, "mmm")
    yearStr = Format(Now, "yyyy")
   
    ' New folder name in "day month year" format
    Dim newFolderName As String
    newFolderName = dayStr & " " & monthStr & " " & yearStr
   
    ' Check if the master folder exists
    If fso.FolderExists(masterFolderPath) Then
        ' Get the master folder
        Set masterFolder = fso.GetFolder(masterFolderPath)
       
        ' Rename the master folder
        masterFolder.Name = newFolderName
       
        ' Display a message when the process is complete
        MsgBox "Master folder has been renamed to '" & newFolderName & "'.", vbInformation
    Else
        ' Display an error message if the master folder doesn't exist
        MsgBox "Master folder not found!", vbExclamation
    End If
   
    ' Display a message when the process is complete
    MsgBox "Files with the same first 7 characters have been moved to new folders.", vbInformation
   
    ' Clean up and release objects
    Set dict = Nothing
    Set fso = Nothing
    Set sourceFolder = Nothing
    Set targetFolder = Nothing
    Set masterFolder = Nothing
End Sub