Monty
Well-Known Member
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 you encounter any issues or have further questions, please let me know, and I'll be happy to assist you further.
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:
Code:
#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
Last edited by a moderator: