Outlook attachment save & print

Hello everyone,
I need help on the following Micro, it works but I need to add a second email address that needs to be saved in same directory and print as they arrive. Thank you

Code:

---

Private Declare Function ShellExecute Lib "shell32.dll" Alias _
    "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
 Private WithEvents Items As Outlook.Items
 Private Sub Application_Startup()
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder

    Set Ns = Application.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox)
    Set Items = Folder.Items
 End Sub
 Private Sub Items_ItemAdd(ByVal Item As Object)
    If TypeOf Item Is Outlook.MailItem Then
PrintAttachments Item
    End If
 End Sub
 Private Sub PrintAttachments(oMail As Outlook.MailItem)
    On Error Resume Next
    Dim colAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String

    ' Save attachments to
sDirectory = "C:\Attachments\"
    Set colAtts = oMail.Attachments
    ' email address attachment that needs to be saved
    If colAtts.Count And oMail.SenderEmailAddress ="email address here" Then
            For Each oAtt In colAtts

        'The code looks at the last 4 characters,
        'including the period and will work as long as you use 4 characters in each extension we want to check.
sFileType = LCase$(Right$(oAtt.FileName, 4))

            Select Case sFileType
        ' Add additional file types below
            Case "xlsx", "docx", ".pdf", ".doc", ".xls"

sFile = sDirectory & oAtt.FileName
oAtt.SaveAsFile sFile
                'Print saved attachements
ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
            End Select
        Next
    End If
 End Sub

---

Add another condition as shown below

Code:

---

If colAtts.Count Then
        If oMail.SenderEmailAddress = "email address here" Or _
          oMail.SenderEmailAddress = "another email address here" Then
            For Each oAtt In colAtts

                'The code looks at the last 4 characters,
                'including the period and will work as long as you use 4 characters in each extension we want to check.
                sFileType = LCase$(Right$(oAtt.Filename, 4))

                Select Case sFileType
                        ' Add additional file types below
                    Case "xlsx", "docx", ".pdf", ".doc", ".xls"

                        sFile = sDirectory & oAtt.Filename
                        oAtt.SaveAsFile sFile
                        'Print saved attachements
                        ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
                End Select
            Next
        End If
    End If

---

Perfect. Thank you thank you it worked

hi again.. Is it possible to assign each email to separate folder to save before it prints.

Probably, what did you have in mind?

I don't know how to do that, I was thinking email 1 be saved on folder 1 then print, email 2 be saved on folder 2 then print.

You missed the point of my question. Where do you want to save the messages? How is it determined what Folder1 and Folder2 are? Are they Outlook folders or Windows filing system folders? If the former you can use rules to do that. If the latter you must bear in mind what to do about duplicate filenames.
Also is it the messages that you want to print now or the attachments? You later message suggest the former whereas the thread was originally about the latter.

sorry bro, I want to save and print attachments only.
right now I am working only with 2 email address but I don't want to save both email attachments on the same directory ("C:\Attachments\")
email-one to be saved on "C:\folder1\"
email-two to be saved on "C:\folder2\"

Thanks gmayor.

OK, in that case replace the section with the following, which I think should do the job

Code:

---

If colAtts.Count Then
    Select Case oMail.SenderEmailAddress
        Case "email address here"
            sDirectory = "C:\Path\Folder1\"
        Case "another email address here"
            sDirectory = "C:\Path\Folder2\"
        Case Else: Exit Sub
    End Select
    For Each oAtt In colAtts
        'The code looks at the last 4 characters,
        'including the period and will work as long as you use 4 characters in each extension we want to check.
        sFileType = LCase$(Right$(oAtt.Filename, 4))

        Select Case sFileType
                ' Add additional file types below
            Case "xlsx", "docx", ".pdf", ".doc", ".xls"

                sFile = sDirectory & oAtt.Filename
                oAtt.SaveAsFile sFile
                'Print saved attachements
                ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
        End Select
    Next
End If

---

great its working, thanks again. Graham

Hi,
i´v been using the vba code below with sucess. however an issue ocourred. if i receive a file with more than one dot ex: 1.23.pdf the vba code does note recocnize it as a pdf file, and doe not print it. iv tried add aditional file extension but no sucess. can you please help me?
of corse if i rename the file it works but its nott a solution for me

Thans in advance

Carlos Pires

Quote:

---

Originally Posted by gmayor

OK, in that case replace the section with the following, which I think should do the job

Code:

---

If colAtts.Count Then
    Select Case oMail.SenderEmailAddress
        Case "email address here"
            sDirectory = "C:\Path\Folder1\"
        Case "another email address here"
            sDirectory = "C:\Path\Folder2\"
        Case Else: Exit Sub
    End Select
    For Each oAtt In colAtts
        'The code looks at the last 4 characters,
        'including the period and will work as long as you use 4 characters in each extension we want to check.
        sFileType = LCase$(Right$(oAtt.Filename, 4))

        Select Case sFileType
                ' Add additional file types below
            Case "xlsx", "docx", ".pdf", ".doc", ".xls"

                sFile = sDirectory & oAtt.Filename
                oAtt.SaveAsFile sFile
                'Print saved attachements
                ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
        End Select
    Next
End If

---

---

Hi,
i´v been using the vba code below with sucess. however an issue ocourred. if i receive a file with more than one dot ex: 1.23.pdf the vba code does note recocnize it as a pdf file, and doe not print it. iv tried add aditional file extension but no sucess. can you please help me?
of corse if i rename the file it works but its nott a solution for me

Thans in advance

Carlos Pires

It works here, unless the PDF file is protected against printing.

Try the following variation - and if it is the extra period that is causing the problem, remove the apostrophe that is blocking the line

Code:

---

sFile = Replace(Left(sFile, Len(sFile) - Len(sFileType)), Chr(46), "_") & sFileType

---

Code:

---

Private Sub PrintAttachments(oMail As Outlook.MailItem)


    On Error Resume Next
    Dim olAtts As Outlook.Attachments
    Dim oAtt As Outlook.Attachment
    Dim i As Long
    Dim sFile As String
    Dim sDirectory As String
    Dim sFileType As String


    Set olAtts = oMail.Attachments


    If olAtts.Count > 0 Then
        Select Case oMail.SenderEmailAddress
            Case "emailaddress1"
                sDirectory = "C:\Path\Folder1\"
            Case "emailaddress2"
                sDirectory = "C:\Path\Folder2\"
            Case Else: Exit Sub
        End Select
    End If


    For i = olAtts.Count To 1 Step -1
        Set oAtt = olAtts(i)
        sFile = olAtts(i).fileName
        sFileType = Right(sFile, Len(sFile) - InStrRev(sFile, Chr(46)) + 1)
        Select Case sFileType
            Case ".xlsx", ".docx", ".pdf", ".doc", ".xls"
                sFile = oAtt.fileName
                'sFile = Replace(Left(sFile, Len(sFile) - Len(sFileType)), Chr(46), "_") & sFileType
                sFile = sDirectory & sFile
                oAtt.SaveAsFile sFile
                ShellExecute 0, "print", sFile, vbNullString, vbNullString, 0
        End Select
    Next i
    Set oAtt = Nothing
    Set olAtts = Nothing
End Sub

---