How to make Excel open outlook and save an attachment?

[wigarth]

Hi!

I get a mail everyday with an attachment.
I am trying to get Excel to open Outlok and save the attachment to my desktop

The file have a new name everyday, but it always starts with "transport*****.xlsx" (if that helps)
The mail i recieve can come from several aresses aswell.
It would be nice if the macro didn't save "thousans" of files but just went trough todays files

I get this code to open Outtlook, but i cant figure out what goes wrong after this.
(I get the Message "Finished" when running the macro)

Anyone knows what can be done here?

Code:

Option Explicit

Sub Test()

Dim olApp As Object 'Outlook.Application
Dim olNS As Object 'Outlook.Namespace
Dim olItems As Object 'Outlook.Items
Dim olItem As Object 'Outlook.MailItem
Dim olAttach As Object 'Outlook.Attachment
Dim Flg As Boolean

Const olFolderInbox As Long = 6

On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olApp Is Nothing Then
Set olApp = CreateObject("Outlook.Application")
Flg = True
End If

Set olNS = olApp.GetNamespace("MAPI")
Set olItems = olNS.GetDefaultFolder(olFolderInbox).Items

For Each olItem In olItems
If TypeName(olItem) = "MailItem" Then
If Int(olItem.ReceivedTime) = Date Then
Select Case olItem.SenderEmailAddress
'define wich email adresses to look for attachment from
Case "someone@mail.com", "someone2@mail.com"
On Error Resume Next
Set olAttach = olItem.Attachments.Item(1)
Err.Clear: On Error GoTo 0
If Not olAttach Is Nothing Then
'Look for files with the name under
If olAttach.Filename Like "TRANSPORT*.XLSX" Then
' save the file
olAttach.SaveAsFile Environ("H:\DESKTOP") & Application.PathSeparator & olAttach.Filename


GoTo Finish
End If
End If
End Select
End If
End If
Next

Finish:

MsgBox ("Finished!")
If Flg Then olApp.Quit

End Sub

Thanks in advance
Wigrth

 

[Worf]

Hi

'Excel module
Sub DateComparison()
Dim colItems As Items, rst As Items, j%, att As Attachment, i%, olapp As Outlook.Application
On Error Resume Next
Set olapp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olapp Is Nothing Then Set olapp = CreateObject("Outlook.Application")
Set colItems = olapp.Session.GetDefaultFolder(olFolderInbox).Items ' desired folder
' today mail
Set rst = colItems.Restrict("@SQL=" & "%today(" & AddQ("urn:schemas:httpmail:datereceived") & ")%")
For i = 1 To rst.Count
    For j = 1 To rst.Item(i).Attachments.Count
        Set att = rst.Item(i).Attachments.Item(j)
        If att.Filename Like "transport*.xlsx" Then _
        att.SaveAsFile GetDesktop & "\" & Replace(Date, "/", "_") & att.Filename
Next j, i
End Sub

Function GetDesktop$()
Dim oWSHShell As Object
Set oWSHShell = CreateObject("WScript.Shell")
GetDesktop = oWSHShell.SpecialFolders("Desktop")
Set oWSHShell = Nothing
End Function
       
Public Function AddQ$(ByVal SchemaName$)
On Error Resume Next
AddQ = Chr(34) & SchemaName & Chr(34)
On Error GoTo 0
End Function

 

[wigarth]

Hi Worf!

First of all, Thank you so much for your answer.
However I am still stuck on this.
When I put your code into a module and execute the macro, I get the following message:
"Compile Error: User defined Type not defined" And it highlights in blue the text: "colItems As Items" in the module
I tried to fool around a bit thinking it might be spelling errors, but I got nothing.

I use Excel2010 if that matters

Best reggards
Wigarth

 

[Worf]

Hi

Add a reference at VBE>Tools>References>Microsoft Outlook xx Object Library.

 

[wigarth]

Hi again, and thanks again for taking the time to help me solve this.


Your latest suggestion took the fault code away.
However, it still does not work.
No file shows up on my desktop.


I am 100 % sure the mail is from today, and that the file is in that mail and also that there are no spelling misstakes.


Any other suggestions?


Best reggards:
Wigarth

 

[Worf]

The version below has message boxes that should help by isolating the issue:

'Excel module
Sub DateComparison()
Dim colItems As Items, rst As Items, j%, att As Attachment, i%, olapp As Outlook.Application
On Error Resume Next
Set olapp = GetObject(, "Outlook.Application")
Err.Clear: On Error GoTo 0
If olapp Is Nothing Then Set olapp = CreateObject("Outlook.Application")
Set colItems = olapp.Session.GetDefaultFolder(olFolderInbox).Items ' desired folder
MsgBox "Folder has " & colItems.Count & " items."
Set rst = colItems.Restrict("@SQL=" & "%today(" & AddQ("urn:schemas:httpmail:datereceived") & ")%")
MsgBox rst.Count & " message(s) today."
For i = 1 To rst.Count
    For j = 1 To rst.Item(i).Attachments.Count
        MsgBox "Message has " & rst.Item(i).Attachments.Count & " attachments."
        Set att = rst.Item(i).Attachments.Item(j)
        If att.Filename Like "transport*.xlsx" Then
            MsgBox "File was found!"
            att.SaveAsFile GetDesktop & "\" & Replace(Date, "/", "_") & att.Filename
        End If
Next j, i
Set att = Nothing: Set rst = Nothing
Set colItems = Nothing: Set olapp = Nothing
End Sub

 

[wigarth]

Hi again and Thank you so much for your time and effort.
It did not work ... again.



But, I removed the .xlsx statement in the code and just used "transport*" instead.
That solved it.

It seems it is case sensitive as well (Never thought of that)


So now only thing left to do is to write the rest of the code to simplyfy my work


Know that your effort is highly appreciated , Thank you so much!

Hope I can retun the favour some time.

Best Reggards:
Wigarth