PDA

View Full Version : Sleeper: Download .xlsm from outlook



samuelimtech
08-26-2014, 02:15 AM
Hi all,

first of all thanks for any help.

I have the following code and for some reason it keeps failing at the next (just above the commented out error handler).
I cant see any issues in my logic and quite frankly its frustrating now. can anyone see where im going wrong. i have played around with error handlers in various positions but cant suss it out.


[Sub SaveAttachments()
Dim myOlapp As Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myFolder As Outlook.MAPIFolder
Dim myItem As Outlook.MailItem
Dim myAttachment As Outlook.Attachment
Dim i As Long
Set myOlapp = CreateObject("Outlook.Application")
Set myNameSpace = myOlapp.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myFolder = myFolder.Folders("TS")
For Each myItem In myFolder.Items
If myItem.Attachments.Count <> 0 Then
i = 1
For Each myAttachment In myItem.Attachments
'On Error GoTo Myerrorhandler
'MsgBox Right(myItem.Attachments.Item(i).FileName, 15)
If Right(myItem.Attachments.Item(i).FileName, 5) = ".xlsm" Then
myAttachment.SaveAsFile "T:\Inter Urban\Consultancy Services\Timesheets\Templates\Access\Download\" & myItem.Attachments.Item(i).FileName
Else
End If
i = i + 1
Next
End If
Next
'Myerrorhandler:
Exit Sub
Resume Next
End Sub

mancubus
08-26-2014, 02:52 AM
try...


myPath = "T:\Inter Urban\Consultancy Services\Timesheets\Templates\Access\Download\"

For Each myAttachment In myItem.Attachments
If Right(myAttachment.FileName, 5) = ".xlsm" Then
myAttachment.SaveAsFile myPath & myAttachment.FileName
End If
Next

samuelimtech
08-26-2014, 03:17 AM
Hi thanks for the response but this hasnt helped, im still getting the same type mismatch erro message, whats wierd is if i just f8 it on then the macro works completely fine to the end??

mancubus
08-26-2014, 04:15 AM
this is a working example that i use regularly.



Sub Save_Mail_Attach_XLSM_Files()
Dim MailItem As Object, Att As Object
Dim fPath As String
Dim calc As Long

With Application
.EnableEvents = False
.ScreenUpdating = False
.DisplayAlerts = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

fPath = "H:\MyFiles\"
With CreateObject("Outlook.Application")
With .GetNamespace("MAPI")
With .Folders("Mailbox - Name Surname (Department Name)")
With .Folders("Inbox")
On Error Resume Next
For Each MailItem In .Items
With MailItem
For Each Att In .Attachments
If CreateObject("Scripting.FileSystemObject").GetExtensionName(Att.FileName) = "xlsm" Then
Att.SaveAsFile fPath & Att.FileName
End If
Next
On Error Goto 0
End With
Next
End With
End With
End With
End With

With Application
.EnableEvents = True
.Calculation = calc
End With
End Sub



for my case Folders("Mailbox - Name Surname (Department Name)") is the top folder that contain Inbox, etc...

snb
08-26-2014, 04:18 AM
Sub M_snb()
For Each it in CreateObject("Outlook.Application").GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("TS").Items
For each at in it.Attachments
If Right(at.FileName, 5) = ".xlsm" Then at.SaveAsFile "T:\Inter Urban\Consultancy Services\Timesheets\Templates\Access\Download\" & at.FileName
next
next
End Sub

NB. I can't check the structure of your Outlook folders
I can't check the validity of your folderstucture on drive T