save email attachment

[benjamin132]

Hello everyone,
i need to save and attachment from a mail box named "Autot archiv" on my computer.
2 month ago i create a script that collect data from a email like subject, Title, received time ... but without attachement.
I don't know why this script does not work anymore i have an error " Sub or function undefined".
Do you know why ? and do you know how to collect attachement?
Thanks by advance

Sub GetFromOutlook()

Dim OutlookApp As Outlook.Application
Dim OutlookNamespace As Namespace
Dim Folder As MAPIFolder
Dim OutlookMail As Variant
Dim i As Integer

Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set Olinbox = OutlookNamespace.GetDefaultFolder(olFolderInbox)
Set Folder = OutlookNamespace.GetDefaultFolder(olFolderInbox).Folders("Autot")
i = 1
For Each OutlookMail In Folder.Items
     Define
     Range("C" & Rows.Count).End(xlUp).Offset(1, 0).Value = OutlookMail.Subject
     Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = OutlookMail.ReceivedTime
     Range("B" & Rows.Count).End(xlUp).Offset(1, 0).Value = OutlookMail.Body
     i = i + 1
Next OutlookMail
While 0 < Len(Folder)
    Folder.Items(1).Move Olinbox.Folders("Autot archiv")
Wend
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing


End Sub

 

[Anthony47]

What is that "Define" in the For Each OutlookMail In Folder.Items / Next OutlookMail loop?
On which line do you receive that error?

To save the attachments (potentially more than one) you could add this snippet in your current For Each OutlookMail In Folder.Items / Next OutlookMail loop:

        AttCnt = OutlookMail.Attachments.Count
        If AttCnt > 0 Then
            For I = 1 To AttCnt
                'Sistema il nome file:
                AName = OutlookMail.Attachments(I).DisplayName
                Pref = Format(OutlookMail.ReceivedTime, "yy-mm-dd_hh-mm-ss_")
                'save attachment:
                    OutlookMail.Attachments(I).SaveAsFile "C:\MAILATTACH\" & Pref & AName
            Next I
        End If

The files will be saved in the directory C:\MAILATTACH\ and each saved filename has a prefix in the format yy-mm-dd_hh-mm-ss, referred to the email received time

Also, in your current For Each OutlookMail In Folder.Items / Next OutlookMail loop I see the risk that the information can get mixed, as you calculate for each piece of info which is the destination row. I would calculate it only once, based on the ReceivedDate column:

Dim NextR As Long
'.
'.
For Each OutlookMail In Folder.Items
''' ???     Define
    NextR = Range("A" & Rows.Count).End(xlUp).Row + 1
    Range("C" & NextR).Value = OutlookMail.Subject
    Range("A" & NextR).Value = OutlookMail.ReceivedTime
    Range("B" & NextR).Value = OutlookMail.Body
    i = i + 1
    'Added instruction to save the attachments:
    AttCnt = OutlookMail.Attachments.Count
    If AttCnt > 0 Then
        For i = 1 To AttCnt
            'Sistema il nome file:
            AName = OutlookMail.Attachments(i).DisplayName
            Pref = Format(OutlookMail.ReceivedTime, "yy-mm-dd_hh-mm-ss_")
            'save attachment:
                OutlookMail.Attachments(i).SaveAsFile "C:\MAILATTACH\" & Pref & AName
        Next i
    End If
Next OutlookMail

I have added the instruction for saving the attachments

 

[benjamin132]

Wow Anthony 47, thats works wonderfull.Thanks a lot.
Yeah i don't know what was this "define" and it was that the bug. Sorry for my English I am a young French :D
if it's not too much to ask, do you know now how to open this attachment (it is a zip, with an excel file inside, that i need to open in order to compare automaticaly some data with other files)
So at this end of this macro, add a small part to open the Excel file inside the zip .

Thanks by advance

 

[Anthony47]

So while you save each attachment, if it 's a zip file you would like to extract the zipped files?
Well, I do that job with the following code (tested on Win 10 & Win 11):

Sub FileDeZip()
Dim ZipFile As String, OutPath As String, ZipPath As String
'
ZipPath = ThisWorkbook.Path & "\"       '<<< Path of the .zip file
OutPath = "C:\PROVA\"                   '<<< The extraction path
'
ZipFile = Dir(ZipPath & "*.zip")        'Get a Zip file
'
Set sh = CreateObject("Shell.Application")
    sh.Namespace(OutPath & "").CopyHere sh.Namespace(ZipPath & ZipFile).Items, 16   '16=Overwrite same name
Set sh = Nothing
End Sub

Before integrating this code within your loop you have to solve a possible problem: how dealing with files with the same FileName.xlsx? I don't have a suggestion for this

 

[benjamin132]

Before integrating this code within your loop you have to solve a possible problem: how dealing with files with the same FileName.xlsx? I don't have a suggestion for this

No i don't have the problem don't worry all my files have different name.
That works perfectly you are the god of Excel :D
I juste have a probleme if there is more than 1 zip that take only the first one how can i do to takes all zip.
And last question I promise ^^ there are all time 3 Excel files in the zip with title :
- "LLD_ BRO Or Savoie RIP SD FY22_4502296295_16052022.xlsx"
- "BRO Savoie_Dijon-Lyon__engineering document 11042022.xlsx"
- "BRO Savoie_Chambery_engineering document 11042022.xlsx"
How can I open only the file which contain "LLD" in the beginning of his name ? It is all time the same things 3 files with only 1 with "LLD".
I promise it is my last question ^^ you saved my day, thanks a lot

 

[Anthony47]

If you look around you will understand that I am an Excel apprentice..

Going to your new question, I shoud't modify the extraction process, but at the end, when all the emails have been scanned, I should loop in the extraction directory, searching any file whose name starts by "BRO" and killing each of them. Are you able to create this code?