Save and Print attachments

Hello,

I have a question. I am trying to extend the rules of Outlook. There will be emails coming in from many, many people, all with the same subject line. I want to flag all of these that come in and put them into a folder of their own. This is done currently into an Outlook folder.

What I want to do now is to save the attachment (as all will have the attachment) to a specific folder. I would then like to print a copy of this attachment. I know exactly what is in the file, it is a returned form and will only take one sheet to print on. The attachment is an Excel file.

Can this be done? And can it be run automatically from whence the mail comes in? Thanks for your help! :yes

OK, I think I've got this worked out. All the code below goes into the ThisOutlookSession module. The rationale is, that you need to declare an object "WithEvents" - in this case an items collection. In the app_startup code, refer your chosen collection (in my example, the items in folder "Temp" in my personal folders) to this object. Now the Item_add event for this object will fire when a new mail arrives in that folder. Then you're free to do as you please with it!

Hope this helps
K :-)
[VBA]'expose the items in the target folder to events
Dim WithEvents TargetFolderItems As Items

Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace

Set ns = Application.GetNamespace("MAPI")
Set TargetFolderItems = ns.Folders.Item( _
"Personal Folders").Folders.Item("Temp").Items

Set ns = Nothing

End Sub

Private Sub TargetFolderItems_ItemAdd(ByVal Item As Object)
'when a new item is added to our "watched folder" we can process it
Dim olAtt As Attachment

'you may want to run some tests on the item/attachment(s)
If Item.Attachments.Count = 1 Then
Set olAtt = Item.Attachments(1)
olAtt.SaveAsFile "C:\temp\" & olAtt.FileName
End If

'pass the filepath to the print routine
PrintAtt ("C:\temp\" & olAtt.FileName)

Set olAtt = Nothing

End Sub

Sub PrintAtt(file As String)

Dim xlApp As Object
Dim wb As Object

'in the background, create an instance of xl then open, print, quit
Set xlApp = CreateObject("Excel.Application")
Set wb = xlApp.Workbooks.Open(file)
wb.PrintOut
xlApp.Quit

'tidy up
Set wb = Nothing
Set xlApp = Nothing

End Sub[/VBA]

Sounds like very usefull to me. Did it work fine Zack? Because, if so I want to use it for me too.

Thanks Killian. Much appreaciated!

Haven't tried it yet, but I will very soon. I will let you know how it turned about Carlos.

Thanks Zack.

Bombs on this line.. [vba] Set TargetFolderItems = ns.Folders.Item( _
"Personal Folders").Folders.Item("Temp").Items[/vba]This is Outlook 2003. It is in the folder .. My Name --> Inbox --> Temp .. folder. It doesn't say Personal Folders. I'm pretty sure this is why, but don't know what it should be. Thoughts?

Hi Zack,
yes, you see, when I said:

Quote:

---

(in my example, the items in folder "Temp" in my personal folders)

---

I was being lazy and assuming you'd sort out defining you own folder location. I knew, of course, that it wasn't that easy... :whistle:

Setting a reference to a folder by name in Outlook isn't something available within the object model unless you've got it's full path to hand so I've written a new App_Startup routine that does it. It's not the last word in elegant solutions but it works. Important note: It currently goes down one level from the main folders (usually <your name>mailbox and Personal Folders, if you have added those) and returns the FIRST instance of a folder named "Temp", so you might have to tweak it a bit.

I put a folder called "Temp" in my Mailbox (same level as InBox, Sent Items etc) and it works (OL2003) so it should be fine...: pray2:

Enjoy
K :-)
[VBA]Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
Dim TargetFolder As MAPIFolder
Dim fldr As MAPIFolder, subfldr As MAPIFolder

Set ns = Application.GetNamespace("MAPI")
For Each fldr In ns.Folders
For Each subfldr In fldr.Folders
If subfldr.Name = "Temp" Then
Set TargetFolderItems = subfldr.Items
Exit For
End If
Next
Next
Set ns = Nothing
End Sub[/VBA]

Quote:

---

Originally Posted by Killian

I was being lazy and assuming you'd sort out defining you own folder location. I knew, of course, that it wasn't that easy... :whistle:

---

You know, Killian, this just screams KB submission to me! :*)

Okay, yes yes, I'm a retard, I know. I will try it.

I receive excel sheets as attachments which I then review respond then save them. I also used the rule wizard to put the new messaqges in a folder. I highlight the folder once a week and run the code. I wrote the code below to check the attachments file names and put them in the proper folder on the hard drive. The form (CurAtchmntStatusFrm) shows the status as the files are being saved and notifes me of files that are out of the norm. I review then select all and delete. The code is rough I don't program for a living more of a hobby but, I think it can be adapted for your use I haven't cleaned it up so it's as is. Path sPathName = "C:\Documents and Settings\YourFolder\My Documents\XL\Hrs\ well have to be a valid folder. Hope this helps :friends:

[VBA]
Option Base 1
Public Sub CleanOutOlFldAthmntsMain()
Static CurOlMsgsAtchmntCnt As Integer
Dim VarArry()

CurYear = Year(Date)
iAttachCntTot = 0
icnt = 0
'ArryCntr = 0

'Code Below Same as In UserForm
Set oCurFldrSlctd = Outlook.ActiveExplorer.Selection.Parent.CurrentFolder 'Outlook Current Folder Selected
Set OlMsgObj = oCurFldrSlctd.Items 'Outlook Current Selected Folder All Message Items
OlMsgCnt = OlMsgObj.Count 'Count of Outlook Current Selected Folder All Message Items

'Get File Info:
For MsgCntr = 1 To OlMsgCnt
LoopCtnr = 0
Set OlMsgObjI = OlMsgObj.Item(MsgCntr) 'Message item number in folder
Set OlMsgObjIAtchmts = OlMsgObjI.Attachments 'All Current Attachments in message
CurOlMsgsAtchmntCnt = OlMsgObjI.Attachments.Count ' Count of All Attachments in current message

For CurOlMsgsAtchmntCntr = 1 To CurOlMsgsAtchmntCnt
sPathNameLbl = ""
OpType = ""
LoopCtnr = LoopCtnr + 1
If LoopCtnr > CurOlMsgsAtchmntCnt Then
Exit For
End If
Set CurOlMsgAtchmnt = OlMsgObjIAtchmts.Item(CurOlMsgsAtchmntCntr)
CurStatus = ""
SavToHolidyFldr = ""
'Chk If File is Elect.Xls:
If Not CurOlMsgAtchmnt Like "*elec*" Then
GoTo NonEltFlTyp
End If
HldyChkNam = Array("*Day*", "*Christmas*", "*4TH*", "*MLK*", "*THANKSGIVING*", "*MEM*", "*EASTER*")
icnt = 0
For Each XItem In HldyChkNam
icnt = icnt + 1
Next XItem
For HldyChk = 1 To icnt
If CurOlMsgAtchmnt Like "*" & HldyChkNam(HldyChk) & "*" Then
SavToHolidyFldr = "Holiday\"
Exit For
End If
Next HldyChk

If CurOlMsgAtchmnt Like "*charge*" Then
SavToPathFldr = "charges\"
ElseIf CurOlMsgAtchmnt Like "*newhour*" Then
SavToPathFldr = "Newhours\"
ElseIf CurOlMsgAtchmnt Like "*asking*" Then
SavToPathFldr = "Asking\"
ElseIf CurOlMsgAtchmnt Like "*Assign*" Then
SavToPathFldr = "Assignments\"
Else
SavToPathFldr = "Assignments\"
End If

sPathName = "C:\Documents and Settings\YourFolder\My Documents\XL\Hrs\" & SavToPathFldr & SavToHolidyFldr 'My Folder Path where to save attachments
sPathNameLbl = "C:\My Documents\XL\Hrs\" & SavToPathFldr & SavToHolidyFldr 'My Folder Path where to save attachments
CurStatus = "Is Being Saved To"
OpType = "SaveAsFile"
AtthmtsSavdQty = AtthmtsSavdQty + 1
GoTo IsEltFlTyp

NonEltFlTyp:
If CurOlMsgAtchmnt Like "*carp*" Then
'iCtr = iCtr - 1
AtthmtsDeldQty = AtthmtsDeldQty + 1
CurStatus = "Deleting File"
OpType = "Delete"
ElseIf CurOlMsgAtchmnt Like "*comm*" Then
'iCtr = iCtr - 1
AtthmtsDeldQty = AtthmtsDeldQty + 1
CurStatus = "Delete"
OpType = "Delete"
Else
OpType = "No Action"
End If
IsEltFlTyp:
iLoopCnt = iLoopCnt + 1
'Pass Variables to UserForm
Load CurAtchmntStatusFrm
CurAtchmntStatusFrm.sPathName = sPathName
CurAtchmntStatusFrm.FileName = CurOlMsgAtchmnt
CurAtchmntStatusFrm.OpType = OpType 'Operation top perform Delete / SaveAs
CurAtchmntStatusFrm.MsgCntr = MsgCntr
CurAtchmntStatusFrm.CurOlMsgsAtchmntCntr = CurOlMsgsAtchmntCntr
CurAtchmntStatusFrm.CurOlMsgsAtchmntCnt = CurOlMsgsAtchmntCnt
CurAtchmntStatusFrm.Caption = oCurFldrSlctd & " Outlook Folder"
CurAtchmntStatusFrm.CurAthmtFlNam.Caption = CurOlMsgAtchmnt
CurAtchmntStatusFrm.CurStatusLbl.Caption = CurStatus
CurAtchmntStatusFrm.CurFileSavPathLbl.Caption = sPathNameLbl
If OpType = "Delete" Then
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Do you really want to Delete " & CurOlMsgAtchmnt ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.
Title = "ARE YOU SURE" ' Define title.
' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
OpType = "Delete" ' Perform some action.
CurOlMsgsAtchmntCntr = CurOlMsgsAtchmntCntr - 1
'OlMsgObjI.Display
Else ' User chose No.
OpType = "No Action"
Exit For
End If
'MsgBox ("Do you really want to Delete! " & FileName)
End If
CurAtchmntStatusFrm.StartUpPosition = 1
CurAtchmntStatusFrm.Show
Next CurOlMsgsAtchmntCntr
Next MsgCntr
GoTo EndIt
NoCanDo:
If iAttachCntTot = 0 Then
MsgBox (" NO ATTACHMENTS FOUND ")
Else
'Dim Msg, Style, Title, Response, MyString
Title = iAttachCntTot & " ATTACHMENTS FOUND and " & AtthmtsSavdQty & " Backed up to Hard Drive Folder" ' Define title.
Msg = "Do you want to Delete Messages in " & oCurFldrSlctd & " Folder?" ' Define message.
Style = vbYesNo + vbCritical + vbDefaultButton2 ' Define buttons.

' Display message.
Response = MsgBox(Msg, Style, Title)
If Response = vbYes Then ' User chose Yes.
MyString = "Yes" ' Perform action.
Else ' User chose No.
MyString = "No" ' Perform action.
End If
End If
EndIt:
Unload CurAtchmntStatusFrm

End Sub

[/VBA]

I have a similar issue:::
What I want to do now is to save the attachment (as all will have the attachment) to a specific folder. I would then like to print a copy of this attachment.... However my attachment is a pdf. Will your vba script work if the attachment is a PDF instead of an excel file?

Thanks,
Tclip

Hi Tclip,

In my original code (post #2), at the comment, "'you may want to run some tests on the item/attachment(s)" you can change the If... Then to confirm the filename (i.e. "*.pdf").
Then you just need to modify the PrintAtt to print PDF's:[VBA]Sub PrintAtt(file As String)
'set a reference (Tools>References) to Adobe Acrobat type library

Dim AcroApp As CAcroApp
Dim AVDoc As CAcroAVDoc
Dim PDDoc As CAcroPDDoc
Dim NumPages As Long

Set AcroApp = CreateObject("AcroExch.App")
Set AVDoc = CreateObject("AcroExch.AVDoc")

AVDoc.Open file, ""
Set PDDoc = AVDoc.GetPDDoc
NumPages = PDDoc.GetNumPages

AcroApp.Show
AVDoc.PrintPages 0, NumPages, 1, True, True

End Sub[/VBA]

Killian

I managed to use the first piece of code successfully, with a couple of changes. Thanks for that.

In an attempt to give me more time to drink coffee and photograph things I probably shouldn't :eek: (!!) is it possible to save the attachements and incorporate the name / e-mail address of the sender into the file name?

Many Thanks
Dave

Dave, if you haven't checked it out already, you might be interested in reading my recent print attachments thread. It includes a module I've developed that provides a function to print any type of attachment using the default program for that file type, which could be useful if you ever need to print anything outside of Excel.

Also, thanks to a security patch installed in Outlook 2000 SR2 or greater, Outlook displays a popup box anytime a macro attempts to read/write a stored contact name or email address. If you want to incorporate the sender's information into the saved filename, you'll probably have to do one of the following:

1. Manually click Yes each time the macro performs this operation.
2. Install Express ClickYes on your system to click this button for you.
3. Install Outlook Redemption so you can create a SafeMailItem object that can give you this information without displaying the popup.

I've never actually experimented with either of the last two options, so if you're still interested in pursuing this, you might have to experiment a bit on your own.

Good luck!

Thanks, I will keep that in mind and probably look to use either of the tools you mentioned.

The fact is that I am close to having everything I need to make the process run smoothly, being able to name each file is the only thing that is required. Otherwise the attachments just replace each other if they are named the same.

If anyone can suggest how to name the files with consecutive numbers rather than the actual name of the person, the rest of the process can be changed to incoporate this???

Cheers again

Try this procedure out. It'll rename the file based on how many files are already in the specified folder, so the attachments will always be sequential so long as no other files are sporadically saved there.

[VBA]
' Renames attachment to sequential number and stores in folder
Public Sub SaveToFolder(Atm As Attachment, FilePath As String)
Dim f As Object ' Folder holding FilePath
Dim fs As Object ' FileSystemObject
Dim FileName As String ' Name to save file

Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(FilePath)
FileName = Atm.FileName
' Get file extension
If InStr(FileName, ".") = 0 Then
Debug.Print "No extension"
FileName = ""
Else:
Debug.Print "Extension"
Do
FileName = Mid(FileName, InStr(FileName, ".") + 1)
Loop While InStr(FileName, ".")
FileName = "." & FileName
End If
' Create full file path
FileName = FilePath & "\" & Format(f.Files.count, "00000000") & FileName
' Save file
Debug.Print FileName
Atm.SaveAsFile FileName
End Sub
[/VBA]

Cheers, I'll have a try.

Thanks again, much appreciated.

Hello,
every day I receive an email with 2 attachments, I want to copy from my inbox the first in an X folder and the second in a Y folder in my hard drive.
Thanks.