Command button to download all attachments recieved today from a specific sender.

[ecalid]

Good morning all,

I am having a spot of bother with some code, I have pieced together most of it and keep getting the runtime error '438': Object doesn't support this property or method.

Basically I need to be able to press a button which then downloads all attachments sent to my inbox today, from a specific sender. And I need to be able to generate the folder as well as this will be given to multiple employees in the company to use and they will not likely have the folder in question.

Also, I think this code will only find the latest email, and not all emails delivered today. I am unsure of how to change this.

Please see the code below:

Private Sub CommandButton1_Click()
Dim ol As Object 'Outlook.Application
Dim Ns As Object 'Outlook.Namespace
Dim i As Object
Dim mi As Object 'Outlook.MailItem
Dim inboxFol As Object 'Outlook.Folder
Dim colItems As Object 'Outlook.Items
Dim strFilter As String
Dim resItems As Object
Set ol = CreateObject(Class:="Outlook.Application")
Set Ns = ol.GetNamespace("MAPI")
Set inboxFol = Ns.GetDefaultFolder(6) 'olFolderInbox
Set colItems = inboxFol.Items
colItems.Sort "[SentOn]", False ' oldest to newest
strFilter = "[SentOn]>'" & Format(Date, "DDDDD HH:NN") & "'"
Debug.Print "strFilter .....: " & strFilter
Set resItems = colItems.Restrict(strFilter)
Debug.Print "resItems.Count: " & resItems.Count
If resItems.Count Then
    For Each i In resItems
        If i.Class = 43 Then
            Set mi = i
            If mi.Attachments.Count > 0 And InStr(mi.SenderName, "Chargehand") Then
                Debug.Print "Subject.....: " & mi.Subject
                Debug.Print "SentOn .....: " & mi.SentOn
                Dim trg As String, src As String
                trg = "C:\user\attachments"
                SpecialMkDir (trg)
                mi.Attachments.SaveAsFile trg & mi.Attachments.Filename
                VBA.FileCopy src, trg
                Exit For ' Exit when the first is found
            End If
        Else
            Debug.Print "no items found."
        End If
    Next i
End If
End Sub
            

Private Sub SpecialMkDir(ByVal path As String)
Dim var As Variant, p As String
Dim i As Integer
var = Split(path, "")
On Error Resume Next
For i = 0 To UBound(var) - 1
    p = p & var(i)
    VBA.MkDir p
    p = p & ""
Next
End Sub

[ecalid]

Could anybody provide any input on this?

[georgiboy]

Try removing the below line, as it is exiting the loop of emails after the first attachment:

Exit For ' Exit when the first is found

[ecalid]

Try removing the below line, as it is exiting the loop of emails after the first attachment:

Exit For ' Exit when the first is found

Thanks for this @georgiboy

I am still getting the error code though, it doesn't seem to like the SaveAsFile function.

[georgiboy]

Have you tried:

mi.Attachments.SaveAsFile trg & "\" & mi.Attachments.Filename

[ecalid]

Have you tried:

mi.Attachments.SaveAsFile trg & "\" & mi.Attachments.Filename

Thanks for this.

Yes I have just tried this but I am still getting the runtime error 438. Debugging on this line.

[georgiboy]

Try as below:

Private Sub CommandButton1_Click()
    Dim ol As Object 'Outlook.Application
    Dim Ns As Object 'Outlook.Namespace
    Dim i As Object
    Dim mi As Object 'Outlook.MailItem
    Dim inboxFol As Object 'Outlook.Folder
    Dim colItems As Object 'Outlook.Items
    Dim strFilter As String
    Dim resItems As Object
    Set ol = CreateObject(Class:="Outlook.Application")
    Set Ns = ol.GetNamespace("MAPI")
    Set inboxFol = Ns.GetDefaultFolder(6) 'olFolderInbox
    Set colItems = inboxFol.Items
    colItems.Sort "[SentOn]", False ' oldest to newest
    strFilter = "[SentOn]>'" & Format(Date, "DDDDD HH:NN") & "'"
    Debug.Print "strFilter .....: " & strFilter
    Set resItems = colItems.Restrict(strFilter)
    Debug.Print "resItems.Count: " & resItems.Count
    If resItems.Count Then
        For Each i In resItems
            If i.Class = 43 Then
                Set mi = i
                If mi.attachments.Count > 0 And InStr(mi.SenderName, "Chargehand") Then
                    Debug.Print "Subject.....: " & mi.Subject
                    Debug.Print "SentOn .....: " & mi.SentOn
                    Dim trg As String
                    trg = "C:\attachments"
                    With CreateObject("Scripting.FileSystemObject")
                        If Not .FolderExists(trg) Then .CreateFolder trg
                    End With
                    mi.attachments.Item(1).SaveAsFile trg & "\" & mi.attachments.Item(1).Filename
                End If
            Else
                Debug.Print "no items found."
            End If
        Next i
    End If
End Sub

[ecalid]

Try as below:

Private Sub CommandButton1_Click()
    Dim ol As Object 'Outlook.Application
    Dim Ns As Object 'Outlook.Namespace
    Dim i As Object
    Dim mi As Object 'Outlook.MailItem
    Dim inboxFol As Object 'Outlook.Folder
    Dim colItems As Object 'Outlook.Items
    Dim strFilter As String
    Dim resItems As Object
    Set ol = CreateObject(Class:="Outlook.Application")
    Set Ns = ol.GetNamespace("MAPI")
    Set inboxFol = Ns.GetDefaultFolder(6) 'olFolderInbox
    Set colItems = inboxFol.Items
    colItems.Sort "[SentOn]", False ' oldest to newest
    strFilter = "[SentOn]>'" & Format(Date, "DDDDD HH:NN") & "'"
    Debug.Print "strFilter .....: " & strFilter
    Set resItems = colItems.Restrict(strFilter)
    Debug.Print "resItems.Count: " & resItems.Count
    If resItems.Count Then
        For Each i In resItems
            If i.Class = 43 Then
                Set mi = i
                If mi.attachments.Count > 0 And InStr(mi.SenderName, "Chargehand") Then
                    Debug.Print "Subject.....: " & mi.Subject
                    Debug.Print "SentOn .....: " & mi.SentOn
                    Dim trg As String
                    trg = "C:\attachments"
                    With CreateObject("Scripting.FileSystemObject")
                        If Not .FolderExists(trg) Then .CreateFolder trg
                    End With
                    mi.attachments.Item(1).SaveAsFile trg & "\" & mi.attachments.Item(1).Filename
                End If
            Else
                Debug.Print "no items found."
            End If
        Next i
    End If
End Sub

Wow, thank you so much! This worked a treat. I can't really figure out where I was going wrong :/

Could I please be annoying and ask for a little more help with this?

Is there a way I could get the script to download all attachments sent today, from the specified email address, and fill in a activeX list box with the downloaded attachments?

[georgiboy]

sent today

Should be taken care of with the below line:

strFilter = "[SentOn]>'" & Format(Date, "DDDDD HH:NN") & "'"

from the specified email address

Should be taken care of with the below line (it's looking for Chargehand in the SenderName):

If mi.attachments.Count > 0 And InStr(mi.SenderName, "Chargehand") Then

and fill in a activeX list box with the downloaded attachments?

Done on the attachment

[georgiboy]

If you want to change it to be from a specific email adress instead of name then maybe change this line:

If mi.attachments.Count > 0 And InStr(mi.SenderName, "Chargehand") Then

To:

If mi.attachments.Count > 0 And mi.senderemailaddress = "blah@blah.com" Then

[ecalid]

If you want to change it to be from a specific email adress instead of name then maybe change this line:

If mi.attachments.Count > 0 And InStr(mi.SenderName, "Chargehand") Then

To:

If mi.attachments.Count > 0 And mi.senderemailaddress = "blah@blah.com" Then

Thank you so much for this, you are a lifesaver.

[georgiboy]

No problem, happy to help.

[Aussiebear]

ecalid, if you are happy with the results here can you mark the thread Solved please?