How to autoprint files in outlook using visual basic
Currently I'm using the following line to print pdfs from an outlook 2003 macro:
Shell """C:\Program Files\Adobe\Reader 8.0\Reader\acrord32.exe"" /h /p """ + Filename + """", vbHide
I wish to be able to print any type of file - eg doc, dwg, xls etc.
If anyone knows a generic command, or list of standard commands to do this, i would be most appreciative. thank you.
I have ms office 2003, vista, adobe8
Shell """C:\Program Files\Adobe\Reader 8.0\Reader\acrord32.exe"" /h /p """ + Filename + """", vbHide
I wish to be able to print any type of file - eg doc, dwg, xls etc.
If anyone knows a generic command, or list of standard commands to do this, i would be most appreciative. thank you.
I have ms office 2003, vista, adobe8
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
For anyone else who needs to do the same thing as me:
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
Sub PrintAttachments()
'Declaration
Dim myItems, myItem, MyAttachments, myAttachment As Object
Dim myOrt As String
Dim printfiletype As String
'Dim myOlApp As New
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim MyAttachmentName As String
'Ask for destination folder
'Dim myItem As Outlook.Inspector
Dim Filename As String
Dim objItem As Object
Set myOlApp = CreateObject("Outlook.Appl
Set myItem = myOlApp.ActiveInspector
'savefiletype = InputBox("What file type do you wish to save?", "Save Attachments", "all")
'Set objItem = myItem.CurrentItem
esubject = myItem
'Prompt the user for confirmation
Dim strPrompt As String
Dim JNum As String
Dim j As Integer
Dim Filetype As String
' restructure string name to get rid of formatting
esubject = Replace(esubject, ":", "")
esubject = Replace(esubject, ".", "")
esubject = Replace(esubject, "/", "")
esubject = Replace(esubject, "!", "")
esubject = Replace(esubject, ",", "")
esubject = Replace(esubject, "'", "")
esubject = Replace(esubject, "(", "")
esubject = Replace(esubject, ")", "")
esubject = Replace(esubject, "?", "")
esubject = Replace(esubject, "*", "")
esubject = Replace(esubject, " ", "_")
esubject = Replace(esubject, Chr(34), "")
esubject = Replace(esubject, Chr(9), "")
esubject = Mid(esubject, 1, 40)
If esubject = "" Then
esubject = "untitled"
End If
' check for job number
JNum = Replace(esubject, " ", "")
For j = 32 To 255 ' get rid of everything except 6 numbers
If j <= 47 Or j >= 58 Then
JNum = Replace(JNum, Chr(j), "")
End If
Next j
JNum = Left(JNum, 6)
'JNum is less than 6 digits, ask the user to enter the job number for a particular subject of an email
j = 10
If Len(JNum) < 6 Then
j = 2000
JNum = InputBox("Enter Job Number:", "No Job Number Found for this email", "")
End If
'work on selected items
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
'for all items do...
For Each myItem In myOlSel 'My Item = subject
'point on attachments
Set MyAttachments = myItem.Attachments
'if there are some...
If MyAttachments.Count > 0 Then
printfiletype = InputBox("What file type do you wish to print (PDF ONLY)?", "Print Attachments", "pdf")
printfiletype = Replace(printfiletype, Chr(34), "")
On Error Resume Next
'add remark to message text
'myItem.Body = myItem.Body & vbCrLf & _
"Removed Attachments:" & vbCrLf
'for all attachments do...
j = 0
For i = 1 To MyAttachments.Count '1:#atmts' 'Myattachments(i) = attachment filename
Filetype = Right(MyAttachments(i), 3)
If Filetype = printfiletype Or printfiletype = "all" Then
' MyAttachments(i) = JNum & "_" & Format(myItem.CreationTime
'save them to destination
' MyAttachments(i).SaveAsFil
' MyAttachments(i).DisplayNa
'add name and destination to message text
' myItem.Body = myItem.Body & _
' "File: " & myOrt & _
' MyAttachments(i).DisplayNa
If Right(MyAttachments(i), 3) = "pdf" Then
' This path must exist! Change folder name as necessary.
Filename = "C:\Temp\ab" & _
Format(myItem.CreationTime
MyAttachments(i).SaveAsFil
'all attachments are first saved in the temp folder C:Temp. Be sure to create this folder.
'please change the program folder accordingly if the Acrobat Reader is not installed on drive C:
Shell """C:\Program Files\Adobe\Reader 8.0\Reader\acrord32.exe"" /h /p """ + Filename + """", vbHide
j = j + 1
Else
Filename = "C:\Temp\ab" & _
Format(myItem.CreationTime
MyAttachments(i).SaveAsFil
ShellExecute 0&, "print", Filename, 0&, 0&, 0&
Kill Filename
j = j + 1
End If
End If
Next i
'for all attachments do...
'While myAttachments.Count > 0
''remove it (use this method in Outlook XP)
''myAttachments.Remove 1
' 'remove it (use this method in Outlook 2000)
' myAttachments(1).Delete
'Wend
'save item without attachments
'myItem.Save
End If
Next
If j = 0 Then
MsgBox "There were no printable attachments for this email"
ElseIf j = 1 Then
MsgBox "There was " & j & " attachment printed to your default printer."
Else
MsgBox "There were " & j & " attachments printed to your default printer."
End If
'free variables
Set myItems = Nothing
Set myItem = Nothing
Set MyAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing 'outlook
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub