Every month I get 50 Adobe .PDF files with 8-15 pages of data. I need to
isolate and print only 1 of the pages. The following code works fine in
Office 2003 under XP, but in Office 2007 under Vista it stops with the cursor
flashing in the FileName box of the File Open dialog of the Adobe Reader.
This "freeze" occurs on the 1st pass through the "For each f in ff" , but the
code continues on to inserting the appropraitely named worksheet (without the
page image from Adobe) and actually stops with an "Invalid Procedure Call" on
the "AppActivate app_is" line the second time through (apparently it can't
activate the Adobe reader while it is frozen, awaiting a file name, from the
1st pass).

As I said this process works fine under XP/Office 2003. Has there been some
kind of change in the Sendkeys method between Office 2003 and 2007, or does
it have to do with XP vs Vista? And in either event, how do I get it running
as we will soon be moving to Vista with Office 2007 and I really don't want
to start doing this manually.

<<<<<<<<Code Begins
Sub fn_PrintPDF()
Dim fs As Object, fp As Object, ff As Object
Dim app_is As Long, x As Long
Dim fname As String, dPath As String

Set fs = Nothing
Set fp = Nothing
Set ff = Nothing

'Enter the path to this month's .pdf files on Sheet1, Cells C3
dir_Name = Sheets("Sheet1").Cells(3, "C").Value

If Len(dir_Name) <= 1 Then
x = MsgBox("Please enter a valid directory name for the " & Chr(10) &
Chr(13) _
& "location of the files to be printed on Sheet1", vbOKOnly)
Sheets("sheet1").Activate
Cells(3, "C").Select
Exit Sub
End If

'Set path to pdf files
dPath = "\\crpatlfnp03\Accounting\" & dir_Name & "\"

Set fs = CreateObject("Scripting.FileSystemObject")
Set fp = fs.GetFolder(dPath)
Set ff = fp.Files

'Initiate Adobe Reader
app_is = Shell("C:\Program Files\Adobe\Acrobat 7.0\Reader\AcroRd32.exe",
vbNormalFocus)

For Each f In ff

'Validate Files are what we want:
If UCase(Right(f.Name, 4)) = ".PDF" Then
fname = f.Name

'Following AppActivate is highlighted line when Invalid Procedure Call error
occurs
AppActivate app_is
'Open file
Application.SendKeys "%FO" & dPath & fname & "{ENTER}", True
'Find 1st Occurence (in Table of Contents)
Application.SendKeys "^FSTATEMENT OF TRANSACTIONS{ENTER}", True
Application.SendKeys "{ESC}", True
Application.SendKeys "{ENTER}", True
' Find 2nd Occurrence in Title of desired page
Application.SendKeys "^FSTATEMENT OF TRANSACTIONS{ENTER}", True
Application.SendKeys "{ESC}", True
'Copy page to the Clipboard
Application.SendKeys "%EB", True

'Add new worksheet
ActiveWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
Range("A6").Select
'Paste Adobe Page to Excel
ActiveSheet.Paste
Range("A3").Select
'Put file name on sheet
ActiveCell.FormulaR1C1 = fname
'Rename sheet
ActiveSheet.Name = fname
Range("A4").Select

'Close file in Adobe Reader
AppActivate app_is
Application.SendKeys ("%FC"), True

End If

'Get next .pdf
Next f

'Exit Adobe Reader
AppActivate app_is
Application.SendKeys ("%FX"), True

'Save this month's file to this month's directory
ActiveWorkbook.SaveAs Filename:=dPath & "PDFExcelRead.xls"

Set fs = Nothing
Set fp = Nothing
Set ff = Nothing

End Sub
<<<<<<<<Code Ends

Thanx a bunch
BAC