Extracting attachments with Macro

  • Thread starter Thread starter Ron P
  • Start date Start date
R

Ron P

Hi everyone.

I have a macro program that was programmed by someone years ago that I am
trying to figure out how it works. The macro would search the inbox for a
specific subject line of "Workorder", Save the excel attachment to a
directory and then delete the email from the inbox. It has worked for years
as there was only one excel attachment to the email, but now corporate IT
guys have changed email policies and as a result the macro no longer works.
This is due to the email now having 2 attachments, there is the excel
attachment and now an additional txt document attachment. How can I get this
to look at just the Excel attachment? I'm kind of at a loss in trying to
figure out how this person coded. It looks straight forward but I'm
apparently missing something.

Sub ExcelExtract()

Dim Item, Attachments, FolderName As Object
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim Folder As Outlook.MAPIFolder
Dim MailItem As Outlook.MailItem


Set myOlExp = myOlApp.ActiveExplorer
Set nsp = myOlApp.GetNamespace("MAPI")
Set Folder = nsp.GetDefaultFolder(olFolderInbox)
x = 0

itemcount = Folder.Items.Count
For Each myitem In Folder.Items
Set Attachments = myitem.Attachments
If InStr(myitem.Subject, "Workorder") > 0 And
myitem.Attachments.Count > 0 Then mycount = mycount + 1
Next

Workordercount = itemcount - mycount
Do Until Folder.Items.Count = Workordercount
For Each Item In Folder.Items
If InStr(Item.Subject, "Workorder") > 0 Then
Set Attachments = Item.Attachments
If Attachments.Count > 0 Then x = x + 1
For i = 1 To Attachments.Count
Attachments(i).SaveAsFile "C:\Worktemp\Workorder" & x &
".xls"
Item.Delete
Next i
End If
Next

Loop
End Sub


Thanks
 
                    Attachments(i).SaveAsFile "C:\Worktemp\Workorder" & x & ".xls"

On my machine, I had to use Attachments.Item(i).SaveAsFile

Try checking for the extension first:

If mid$(Attachments.Item(i).FileName ,
InStrRev(Attachments.Item(i).FileName, ".") +1) = "xls" Then
Attachments(i).SaveAsFile "C:\Worktemp\Workorder" & x & ".xls"
 
Here's one way. This will loop through the emails in your default
Inbox and check each email for the word "Workorder" in the subject. If
found, and there are attachments, it loops through the attachments
until it finds the spreadsheet and saves it to your folder. This is
air code so please test it first.

HTH,
JP


Sub ExcelExtract2()
Dim i As Long
Dim Msg As Outlook.MailItem
Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim MyItems As Outlook.Items
Dim myAttach As Outlook.Attachments
Dim Att As Outlook.Attachment
Dim OrdNum As Long

Set olApp = Application
Set objNS = olApp.GetNamespace("MAPI")
Set MyItems = objNS.GetDefaultFolder(olFolderInbox).Items

For i = MyItems.Count To 1 Step -1
If MyItems.Item(i).Class = olMail Then
Set Msg = MyItems.Item(i)
If (InStr(Msg.Subject, "Workorder") > 0) And
(Msg.Attachments.Count > 0) Then
Set myAttach = Msg.Attachments
For Each Att In myAttach
If UCase$(Right$(Att.FileName, 3)) = "XLS" Then
OrdNum = OrdNum + 1
Att.SaveAsFile "C:\Worktemp\Workorder" & OrdNum &
".xls"
Msg.Delete
End If
Next Att
End If
End If
Next i

End Sub
 
Back
Top