How can I alter thi code to Print Other attachments

[Mister H]

Hi:

With the help of mostly JP2112 I assembled and have been using the code below to flawlessly print Excel documents. Thanks JP2112. What I need to do now is alter it slighty (i hope slightly) so it still does this but that it also prints any other attachments as well. I suspect the attachemnts will be Word and PDF. Can anyone help in this matter or at least point me in the right direction?

Here is my current code:


Sub Print_And_Move_ADI_Emails()
'Constructed by Mark Huggins for the ARIR Processing Staff October 2015.
On Error GoTo ErrorHandler
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim Msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim Filename As String
Set Folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("A) ARIRs to be Printed")

If Folder Is Nothing Then GoTo ProgramExit
For i = Folder.Items.Count To 1 Step -1

If TypeName(Folder.Items(i)) = "MailItem" Then
Set Msg = Folder.Items(i)
Set msgAttachments = Msg.Attachments

If msgAttachments.Count > 0 Then

For Each msgAttach In msgAttachments
If Right$(msgAttach.Filename, 3) = "xls" Or Right$(msgAttach.Filename, 4) = "xlsm" Then
'If Right$(msgAttach.fileName, 3) = "xls" Then

Filename = Environ("temp") & "\" & msgAttach.Filename
msgAttach.SaveAsFile Filename

If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(Filename)
Set xlwksht = xlwkbk.Sheets("ARIR Template-Electronic")
'xl.Run "DelZeroRows" Print_ARIR
xlwksht.PageSetup.LeftHeader = "Email Subject Line is: " & Msg.Subject '& " Message Received Date is: " & Msg.ReceivedTime
xlwksht.PageSetup.RightHeader = "Printed by " & Session.CurrentUser.Name
xlwksht.PageSetup.RightFooter = "Email Received From: " & Msg.SenderName & " on: " & Msg.ReceivedTime
xl.Run "Print_ARIR"
'xlwksht.PrintOut

xlwkbk.Close False
Set xlwkbk = Nothing

End If
Next msgAttach
Msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("B) ARIRs to be Processed")



End If
End If
Next i

ProgramExit:
'Close files and applications if necessary
If Not xlwkbk Is Nothing Then xlwkbk.Close False
If Not xl Is Nothing Then xl.Quit

'Delete the file if necessary
If Filename <> "" Then Kill Filename
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & Chr(10) & Chr(10) & "There is a possibility that not all your files were printed and moved. PLEASE check your Inbox folder titled: 1) ADIs to be Printed" & Chr(10) & Chr(10) & "NOTE: If not all files were Printed and Moved then try clicking the ' Print ADIs ' button again. They may print the 2nd time." & Chr(10) & Chr(10) & "If you keep getting this message then you will have to manually Print and Move the LAST email contained in your folder titled: 1) ADIs to be Printed" & Chr(10) & Chr(10) & "Problem MAY be:" & Chr(10) & "1) It may not be an ADI email 2) It may be an Archived email 3) The Journal sheet may be hidden" & Chr(10) & Chr(10) & "Once you move the first file manually you can once again click on the button titled Print ADIs" & Chr(10) & Chr(10) & "THANKS and Good Luck :-)"
Resume ProgramExit

End Sub


THANKS,
Mark

[Mister H]

Hmmmmm... I was hoping this was an easy one but with Outlook VBA nothing seems easy. Not sure why Excel VBA is so much more user friendly. Anyway, I was in a bit of a hurry when posting so I am reposting the code (cleaned up a bit). As stated earlier I need the Excel portion to remain the same but I need to add some code that states:

IF IT IS ANOTHER FILE FORMAT OTHER THAN EXCEL JUST PRINT THE ATTACHMENT

Here is the slightly revised code that I need to alter :)



Sub Print_And_Move_ARIR_Emails()
On Error GoTo ErrorHandler
Dim i As Long
Dim Folder As Outlook.MAPIFolder
Dim itm As Object
Dim Msg As Outlook.MailItem
Dim msgAttachments As Outlook.Attachments
Dim msgAttach As Outlook.Attachment
Dim xlwkbk As Excel.Workbook
Dim xlwksht As Excel.Worksheet
Dim Filename As String
Set Folder = Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("A) ARIRs to be Printed")

If Folder Is Nothing Then GoTo ProgramExit
For i = Folder.Items.Count To 1 Step -1

If TypeName(Folder.Items(i)) = "MailItem" Then
Set Msg = Folder.Items(i)
Set msgAttachments = Msg.Attachments

If msgAttachments.Count > 0 Then

For Each msgAttach In msgAttachments






'MAYBE something in here that says something like

'If Right$(msgAttach.Filename, 3) <> "xls" Or Right$(msgAttach.Filename, 4) <> "xlsm" Then PRINT ATTACHMENT





If Right$(msgAttach.Filename, 3) = "xls" Or Right$(msgAttach.Filename, 4) = "xlsm" Then

Filename = Environ("temp") & "\" & msgAttach.Filename
msgAttach.SaveAsFile Filename

If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(Filename)
Set xlwksht = xlwkbk.Sheets("ARIR Template-Electronic")
xlwksht.PageSetup.LeftHeader = "Email Subject Line is: " & Msg.Subject
xlwksht.PageSetup.RightHeader = "Printed by " & Session.CurrentUser.Name
xlwksht.PageSetup.RightFooter = "Email Received From: " & Msg.SenderName & " on: " & Msg.ReceivedTime
xl.Run "Print_ARIR"

xlwkbk.Close False
Set xlwkbk = Nothing

End If
Next msgAttach
Msg.Move Outlook.Session.GetDefaultFolder(olFolderInbox).Folders("B) ARIRs to be Processed")



End If
End If
Next i

ProgramExit:
If Not xlwkbk Is Nothing Then xlwkbk.Close False
If Not xl Is Nothing Then xl.Quit

If Filename <> "" Then Kill Filename
Exit Sub

ErrorHandler:
MsgBox Err.Number & " - " & Err.Description & Chr(10) & Chr(10) & "There is a possibility that not all your files were printed and moved. PLEASE check your Inbox folder titled: 1) ADIs to be Printed" & Chr(10) & Chr(10) & "NOTE: If not all files were Printed and Moved then try clicking the ' Print ADIs ' button again. They may print the 2nd time." & Chr(10) & Chr(10) & "If you keep getting this message then you will have to manually Print and Move the LAST email contained in your folder titled: 1) ADIs to be Printed" & Chr(10) & Chr(10) & "Problem MAY be:" & Chr(10) & "1) It may not be an ADI email 2) It may be an Archived email 3) The Journal sheet may be hidden" & Chr(10) & Chr(10) & "Once you move the first file manually you can once again click on the button titled Print ADIs" & Chr(10) & Chr(10) & "THANKS and Good Luck :-)"
Resume ProgramExit

End Sub



It seems like a simple thing but every time I ploay with the code I create errors (Next without For) (No End IF) that I cant seem to fix. Once again if anyone can get me pointed in the right direction that would be awesome.

Have a GREAT day ALL,
Mark

[Charlize]

replace code in between
For Each msgAttach In msgAttachments and
Next msgAttach with


If Right$(msgAttach.Filename, 3) = "xls" Or Right$(msgAttach.Filename, 4) = "xlsm" Then 'If Right$(msgAttach.fileName, 3) = "xls" Then

Filename = Environ("temp") & "\" & msgAttach.Filename
msgAttach.SaveAsFile Filename

If xl Is Nothing Then
Set xl = CreateObject("Excel.Application")
End If
Set xlwkbk = xl.Workbooks.Open(Filename)
Set xlwksht = xlwkbk.Sheets("ARIR Template-Electronic")
'xl.Run "DelZeroRows" Print_ARIR
xlwksht.PageSetup.LeftHeader = "Email Subject Line is: " & Msg.Subject '& " Message Received Date is: " & Msg.ReceivedTime
xlwksht.PageSetup.RightHeader = "Printed by " & Session.CurrentUser.Name
xlwksht.PageSetup.RightFooter = "Email Received From: " & Msg.SenderName & " on: " & Msg.ReceivedTime
xl.Run "Print_ARIR"
'xlwksht.PrintOut

xlwkbk.Close False
Set xlwkbk = Nothing
'ADDED BY CHARLIZE
Else
MsgBox "Watch out !!! Something else as excel-file attached", vbCritical
End If
Beware, keep a copy of your original coding. I can make a mistake to :) :whistle:

Charlize

[skatonni]

Try the technique described here http://www.vbaexpress.com/forum/showthread.php?54131-VBA-Script-error

This part at the top.


Option Explicit

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


This part in the Else, with appropriate changes to the names.


If Not oAtt.FileName Like "image*.*" Then 'Omit images in the message
strFilename = oAtt.FileName
strFullFile = cTmpFld & "\" & strFilename
'save attachment
oAtt.SaveAsFile strFullFile
'print attachment
ShellExecute 0, "print", strFullFile, vbNullString, vbNullString, 0
End If

[Mister H]

Hi Charlize:

THANKS for the code. I just saw your message so I have yet to experiment with the code you provided but I wanted to say THANKS before I do anything. If I have issues I will repost.

Have an AWESOME Day ALL,
Take Care,
Mark :)

[Mister H]

Oops :) I just saw that skatonni (http://www.vbaexpress.com/forum/member.php?5611-skatonni) replied as well. THANKS for your input as well. I am sure between both of your suggested codes as well as a link provided I will be able to get my revised code to run as required. THANKS again to both of you for taking the time to reploy as well as providing your expertise.

Bye 4 now,
Mark :)