Command button to download all attachments recieved today from a specific sender.
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:
Code:
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
