SBryan
07-22-2008, 12:07 AM
I'm writing some code that saves, renames and prints pdf attachments from a monitored folder.
I've been looking at some code from Javavibe (which is a combination of Killian's KB 522 & Acrobat command line code from Masaru Kaji) which I've played around with:
'########################################################################## #####
'### Module level Declarations
'expose the items in the target folder to events
Option Explicit
Dim WithEvents TargetFolderItems As Items
'set the string constant for the path to save attachments
Const FILE_PATH As String = "P:\Test\"
'########################################################################## #####
'### this is the Application_Startup event code in the ThisOutlookSession module
Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
Dim Inbox As MAPIFolder
Set ns = Application.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Assessments")
Set TargetFolderItems = Inbox.Items
End Sub
'########################################################################## #####
'### this is the ItemAdd event code
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
Dim i As Integer
Dim FileName As String
If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
'rename file if attachment is pdf
'If UCase(Right(olAtt.FileName, 3)) = "pdf" Then
FileName = olAtt.FileName
FileName = Mid(FileName, 7, 8) & ".pdf"
'save the attachment if pdf
olAtt.SaveAsFile FILE_PATH & FileName
PrintAtt (FILE_PATH & FileName)
Next
End If
Set olAtt = Nothing
End Sub
'########################################################################## #####
'### this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
'########################################################################## #####
'### print routine
Sub PrintAtt(fFullPath As String)
PrintPDF2 (fFullPath), 1
End Sub
Sub PrintPDF2(ByVal FileName As String, Optional Copies As Long = 1)
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ Prints the PDF files using a command line.
'++ Written by Masaru Kaji aka Colo
'++ Syntax
'++ FileName : Required String expression that specifies a file name
'++ - may include directory or folder, and drive..
'++ Copies : Optional Long. The number of copies to print.
'++ If omitted one copy is printed.
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim cnt As Long
Dim myShell
Set myShell = CreateObject("WScript.Shell")
Dim Acro As AcroApp
Set Acro = New AcroApp
For cnt = 1 To Copies
'opens Acrobat and prints file
myShell.Run ("C:\Program Files\Adobe\Reader 8.0\Reader\AcroRd32.exe/p" & FileName)
Next
'tidy up
Acro.Exit
End Sub
The code works perfectly up until it tries to print the PDF. It fails at the line:
Set Acro = New AcroApp with the error: Runtime error '429' ActiveX component can't create object.
I have also tried this code, which was suggested has been suggested by Killian previously: 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 which fails at Set AcroApp = CreateObject("AcroExch.App") with the error message being: Runtime error '-214722105 (800401f3) The Operation Failed.
Does anyone have any idea what I'm doing wrong? I have referenced the Adobe Acrobat 8.0 type Library.
Any help would be appreciated,
Stephen
I've been looking at some code from Javavibe (which is a combination of Killian's KB 522 & Acrobat command line code from Masaru Kaji) which I've played around with:
'########################################################################## #####
'### Module level Declarations
'expose the items in the target folder to events
Option Explicit
Dim WithEvents TargetFolderItems As Items
'set the string constant for the path to save attachments
Const FILE_PATH As String = "P:\Test\"
'########################################################################## #####
'### this is the Application_Startup event code in the ThisOutlookSession module
Private Sub Application_Startup()
'some startup code to set our "event-sensitive" items collection
Dim ns As Outlook.NameSpace
Dim Inbox As MAPIFolder
Set ns = Application.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("Assessments")
Set TargetFolderItems = Inbox.Items
End Sub
'########################################################################## #####
'### this is the ItemAdd event code
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
Dim i As Integer
Dim FileName As String
If Item.Attachments.Count > 0 Then
For i = 1 To Item.Attachments.Count
Set olAtt = Item.Attachments(i)
'rename file if attachment is pdf
'If UCase(Right(olAtt.FileName, 3)) = "pdf" Then
FileName = olAtt.FileName
FileName = Mid(FileName, 7, 8) & ".pdf"
'save the attachment if pdf
olAtt.SaveAsFile FILE_PATH & FileName
PrintAtt (FILE_PATH & FileName)
Next
End If
Set olAtt = Nothing
End Sub
'########################################################################## #####
'### this is the Application_Quit event code in the ThisOutlookSession module
Private Sub Application_Quit()
Dim ns As Outlook.NameSpace
Set TargetFolderItems = Nothing
Set ns = Nothing
End Sub
'########################################################################## #####
'### print routine
Sub PrintAtt(fFullPath As String)
PrintPDF2 (fFullPath), 1
End Sub
Sub PrintPDF2(ByVal FileName As String, Optional Copies As Long = 1)
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
'++ Prints the PDF files using a command line.
'++ Written by Masaru Kaji aka Colo
'++ Syntax
'++ FileName : Required String expression that specifies a file name
'++ - may include directory or folder, and drive..
'++ Copies : Optional Long. The number of copies to print.
'++ If omitted one copy is printed.
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Dim cnt As Long
Dim myShell
Set myShell = CreateObject("WScript.Shell")
Dim Acro As AcroApp
Set Acro = New AcroApp
For cnt = 1 To Copies
'opens Acrobat and prints file
myShell.Run ("C:\Program Files\Adobe\Reader 8.0\Reader\AcroRd32.exe/p" & FileName)
Next
'tidy up
Acro.Exit
End Sub
The code works perfectly up until it tries to print the PDF. It fails at the line:
Set Acro = New AcroApp with the error: Runtime error '429' ActiveX component can't create object.
I have also tried this code, which was suggested has been suggested by Killian previously: 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 which fails at Set AcroApp = CreateObject("AcroExch.App") with the error message being: Runtime error '-214722105 (800401f3) The Operation Failed.
Does anyone have any idea what I'm doing wrong? I have referenced the Adobe Acrobat 8.0 type Library.
Any help would be appreciated,
Stephen