I am writing to seek some help in creating a outlook macro, which is able
extract all xls attachment files into one excel workbook (save each
attachment in individual worksheet) from specific outlook folder called
‘data’, which is sub-folder under the Inbox folder.
I manage to find the following code for excel attachment extraction, but
currently struggling to get it to work.
Sub GetAttachments()
On Error Resume Next
'create the folder if it doesnt exists:
Dim fso, ttxtfile, txtfile, WheretosaveFolder
Dim objFolders As Object
Set objFolders = CreateObject("WScript.Shell").SpecialFolders
'MsgBox objFolders("mydocuments")
ttxtfile = objFolders("mydocuments")
Set fso = CreateObject("Scripting.FileSystemObject")
Set txtfile = fso.CreateFolder(ttxtfile & "\Email Attachments")
Set fso = Nothing
WheretosaveFolder = ttxtfile & "\Email Attachments"
On Error GoTo GetAttachments_err
' Declare variables
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
'Set Inbox = ns.GetDefaultFolder(olFolderInbox)
' added the option to select whic folder to export
Set Inbox = ns.PickFolder
'to handle if the use cancalled folder selection
If Inbox Is Nothing Then
MsgBox "You need to select a folder in order to save the
attachments", vbCritical, _
"Export - Not Found"
Exit Sub
End If
i = 0
' Check Inbox for messages and exit of none found
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the selected folder.",
vbInformation, _
"Export - Not Found"
Exit Sub
End If
' Check each message for attachments
For Each Item In Inbox.Items
' Save any attachments found
For Each Atmt In Item.Attachments
' This path must exist! Change folder name as necessary.
'FileName = "C:\Email Attachments\" & Atmt.FileName
'if want to add a filter:
'If Right(Atmt.FileName, 3) = "xls" Then
FileName = WheretosaveFolder & "\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
' Show summary message
If i > 0 Then
MsgBox "There were " & i & " attached files." _
& vbCrLf & "These have been saved to the Email Attachments folder
in My Documents." _
& vbCrLf & vbCrLf & "Thank you for using Liron Segev -
TheTechieGuy's utility", vbInformation, "Export Complete"
Else
MsgBox "There were no attachments found in any mails.",
vbInformation, "Export - Not Found"
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Any further assistance would be very much appreciated. Many thanks
--
Are you =EXP(E:RT) or =NOT(EXP(E:RT)) in Excel? And do you wanna be? It’s
=TIME(2,DO:IT,N:OW) ! Join official Facebook page of this forum @
https://www.facebook.com/discussexcel
FORUM RULES
1) Use concise, accurate thread titles. Poor thread titles, like Please Help,
Urgent, Need Help, Formula Problem, Code Problem, and Need Advice will not get
quick attention or may not be answered.
2) Don't post a question in the thread of another member.
3) Don't post questions regarding breaking or bypassing any security measure.
4) Acknowledge the responses you receive, good or bad.
5) Jobs posting is not allowed.
6) Sharing copyrighted material and their links is not allowed.
NOTE : Don't ever post confidential data in a workbook. Forum owners and
members are not responsible for any loss.
---
You received this message because you are subscribed to the Google Groups "MS
EXCEL AND VBA MACROS" group.
To unsubscribe from this group and stop receiving emails from it, send an email
to excel-macros+unsubscr...@googlegroups.com.
To post to this group, send email to excel-macros@googlegroups.com.
Visit this group at http://groups.google.com/group/excel-macros.
For more options, visit https://groups.google.com/d/optout.
