Hi Bernd,
Danke für den Hinweis.
Ich habe eine VB Klasse für die App pdftotxt.exe von xpdf gefunden. Funktioniert wunderbar.
Performance ist subjectiv weder schneller noch langsamer als die Apps von Adobe Acrobat acrobat.tlb.
Besonders gut an der Klasse ist die Integration der Shell Anweisung und ein ErrorHandler und und...
Die Klasse heißt "clsRunApp", der Author heißt DMaruca, zu finden unter
http://www.vbforums.com/showthread.php?t=589966
Anbei Downloadlink für die clsRunApp
http://www.vbforums.com/attachment.php?attachmentid=76033&d=1265230842
Alternativ habe ich eine wirklich gute BasisAnleitung für AdobeSDK gefunden, quasi die Methode wie man die OLE APP in VBA integriert. Die HomePage heißt Karl Heinz Kremer's Ramblings. Hier gibt es auch den LINK für die Adobe OLE SDK.
Topic adobe-acrobat-and-vba-an-introduction
http://www.khk.net/wordpress/2009/03/04/adobe-acrobat-and-vba-an-introduction/
Developing Applications Using Interapplication Communication
http://www.adobe.com/devnet/acrobat/pdfs/iac_developer_guide.pdf
Interapplication Communication API Reference
http://www.adobe.com/devnet/acrobat/pdfs/iac_api_reference.pdf
Für JavaScriptBridgeVBA
JavaScript for Acrobat API Reference Version 8
http://www.adobe.com/devnet/acrobat/pdfs/js_api_reference.pdf
Developing Acrobat Applications Using JavaScript
http://www.adobe.com/devnet/acrobat/pdfs/js_developer_guide.pdf
Jetzt wieder zurück zu xpdf.
Ich habe die win32 zip Version von xpdf in ein Verzeichnis xy entpackt. Hier gibt es genügend Anleitungen. Im VBA Code wird die ausführende Datei "VerzeichnisXY\pdftotxt.exe" für die Klasse bekanntgegeben. Die Klasse besitzt die Methode add Parameter, die mit den Optionen gem. xpdf Beschreibung pdftotxt.txt übergeben wird.
Anbei mein DirtyCode
!Die "MSGBox s" zeigt nur begrenzt 255 Zeichen an. Liest den Stream in ein Array ein. Irre?! Alle Te4xte des PDF Files wurden gelesen!
'Quelle http://www.vbforums.com/showthread.php?t=589966
Sub ExtractTextDirect()
Dim cls As New clsRunApp
Dim s As String
cls.command = "F:\Andi\VBA_PDF\XPDF\pdftotext.exe" '"C:\Path To\pdftotext.exe"
cls.AddParamater "-layout" 'preserve the layout of the text
'Surrounding quotes will be auto-added to this paramater since it has spaces.
cls.AddParamater "F:\Andi\VBA_PDF\Leistungsauftrag_DKV_Koeln.pdf" '"C:\super long path to pdf file\my pdf file.pdf"
'a hyphen as the next paramater directs output to stdout which we will capture
cls.AddParamater "-"
s = cls.RunAppWait_CaptureOutput
MsgBox s
Set cls = Nothing
End Sub
Das ist die fertige Klasse
'---------------------------------------------------------------------------------------
' Module : clsRunApp
' DateTime : 10/28/2009 11:43
' Author : DMaruca
' Purpose : Runs a shell process. You can build a command using Command and AddParamater.
' Adding a new command clears any existing paramaters.
'
' Example :
' Dim cls As New clsRunApp
' cls.Command = "c:\pdftotext.exe"
' cls.AddParamater "-layout"
' 'Surrounding quotes will be auto added to this param since it has spaces.
' 'No more cluttery shell commands!
' cls.AddParamater "C:\Data\PDF\CLTIC-AK-TR-09-01 NAIC Rate Rule Filing Schedule.pdf"
' cls.AddParamater "C:\temp.txt"
' cls.RunAppWait
'---------------------------------------------------------------------------------------
Option Explicit
'ERROR enumeration and base error number.
Private Const ErrorBase = 1000
Public Enum ErrorRunApp
ApiFailure = ErrorBase
BlankParamater 'Adding a blank paramater
CommandNotFound_ShellCommand 'shell() error
CommandPathNotFound 'Only if using CheckForCommandNotExist
NoCommand 'Trying to run without a command
UnhandledError 'Mysterious
End Enum
'Use by AddParamater. See procedure header for explanation.
Public Enum eQuote
eQuote_Normal
eQuote_ForceNone
eQuote_ForceQuotes
End Enum
' STARTUPINFO flags
Private Const STARTF_USESHOWWINDOW = &H1
Private Const STARTF_USESTDHANDLES = &H100
' ShowWindow flag
Private Const SW_HIDE = 0
'Used by OpenProcess
Private Const PROCESS_QUERY_INFORMATION As Long = &H400
Private Const SYNCHRONIZE As Long = &H100000
'Used by GetExitCodeProcess
Private Const STILL_ACTIVE As Long = &H103
'Used by FormatMessage
Private Const FORMAT_MESSAGE_FROM_SYSTEM As Long = &H1000
Private Const FORMAT_MESSAGE_IGNORE_INSERTS As Long = &H200
Private Const FORMAT_MESSAGE_MAX_WIDTH_MASK As Long = &HFF
Private Const FormatMessageDwFlags = FORMAT_MESSAGE_FROM_SYSTEM Or FORMAT_MESSAGE_IGNORE_INSERTS Or FORMAT_MESSAGE_MAX_WIDTH_MASK
'Error code from VBA Shell()
Private Const ErrFileNotFound = 53
'CreatePipe buffer size
Private Const BUFSIZE = 1024
Private Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Long
End Type
Private Type STARTUPINFO
cb As Long
lpReserved As Long
lpDesktop As Long
lpTitle As Long
dwX As Long
dwY As Long
dwXSize As Long
dwYSize As Long
dwXCountChars As Long
dwYCountChars As Long
dwFillAttribute As Long
dwFlags As Long
wShowWindow As Integer
cbReserved2 As Integer
lpReserved2 As Long
hStdInput As Long
hStdOutput As Long
hStdError As Long
End Type
Private Type PROCESS_INFORMATION
hProcess As Long
hThread As Long
dwProcessId As Long
dwThreadId As Long
End Type
Private Declare Function CloseHandle Lib "kernel32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePipe Lib "kernel32.dll" (ByRef phReadPipe As Long, ByRef phWritePipe As Long, ByRef lpPipeAttributes As SECURITY_ATTRIBUTES, ByVal nSize As Long) As Long
Private Declare Function CreateProcess Lib "kernel32.dll" Alias "CreateProcessA" (ByVal lpApplicationName As String, ByVal lpCommandLine As String, ByRef lpProcessAttributes As SECURITY_ATTRIBUTES, ByRef lpThreadAttributes As SECURITY_ATTRIBUTES, ByVal bInheritHandles As Long, ByVal dwCreationFlags As Long, ByRef lpEnvironment As Any, ByVal lpCurrentDriectory As String, ByRef lpStartupInfo As STARTUPINFO, ByRef lpProcessInformation As PROCESS_INFORMATION) As Long
Private Declare Function FormatMessage Lib "kernel32.dll" Alias "FormatMessageA" (ByVal dwFlags As Long, ByRef lpSource As Any, ByVal dwMessageId As Long, ByVal dwLanguageId As Long, ByVal lpBuffer As String, ByVal nSize As Long, ByRef Arguments As Long) As Long
Private Declare Function GetExitCodeProcess Lib "kernel32.dll" (ByVal hProcess As Long, ByRef lpExitCode As Long) As Long
Private Declare Sub GetStartupInfo Lib "kernel32.dll" Alias "GetStartupInfoA" (ByRef lpStartupInfo As STARTUPINFO)
Private Declare Function OpenProcess Lib "kernel32.dll" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal pszPath As String) As Long
Private Declare Function PeekNamedPipe Lib "kernel32.dll" (ByVal hNamedPipe As Long, ByRef lpBuffer As Any, ByVal nBufferSize As Long, ByRef lpBytesRead As Long, ByRef lpTotalBytesAvail As Long, ByRef lpBytesLeftThisMessage As Long) As Long
Private Declare Function ReadFile Lib "kernel32" (ByVal hFile As Long, ByVal lpBuffer As String, ByVal nNumberOfBytesToRead As Long, lpNumberOfBytesRead As Long, lpOverlapped As Any) As Long
'# -------------------------------------------------------------------------#
'# private variables #
'# -------------------------------------------------------------------------#
Private m_command As String
Private m_paramaters() As String
Private m_checkForCommandNotExist As Boolean
'
'# -------------------------------------------------------------------------#
'# class constructors #
'# -------------------------------------------------------------------------#
Private Sub Class_Terminate()
Erase m_paramaters
End Sub
'# -------------------------------------------------------------------------#
'# errors #
'# -------------------------------------------------------------------------#
'All errors are up front for you to see. This class will not throw any errors
'not found here or in the enum above.
Private Sub ErrorCheck_ApiFailure(proc As String, desc As String)
Err.Raise Number:=vbObjectError + ErrorRunApp.ApiFailure, _
Source:=proc, _
Description:=desc
End Sub
Private Sub ErrorCheck_BlankParamater(proc As String, test As Boolean)
If test Then Err.Raise Number:=vbObjectError + ErrorRunApp.BlankParamater, _
Source:=proc, _
Description:="The paamater is blank."
End Sub
Private Sub ErrorCheck_CommandNotFound_ShellCommand(proc As String)
Err.Raise Number:=vbObjectError + ErrorRunApp.CommandNotFound_ShellCommand, _
Source:=proc, _
Description:="The command specified was not found."
End Sub
Private Sub ErrorCheck_CommandPathNotFound(proc As String, test As Boolean)
If test Then Err.Raise Number:=vbObjectError + ErrorRunApp.CommandPathNotFound, _
Source:=proc, _
Description:="The path specified does not exist."
End Sub
Private Sub ErrorCheck_NoCommand(proc As String, test As Boolean)
If test Then Err.Raise Number:=vbObjectError + ErrorRunApp.NoCommand, _
Source:=proc, _
Description:="No command specified."
End Sub
Private Sub ErrorCheck_UnhandledError(proc As String, Error As ErrObject)
Err.Raise Number:=Error.Number, _
Source:=proc, _
Description:=Error.Description
End Sub
'# -------------------------------------------------------------------------#
'# properties #
'# -------------------------------------------------------------------------#
Public Property Let command(path As String)
If CheckForCommandNotExist Then
ErrorCheck_CommandPathNotFound "Command", Not FileExists(path)
End If
m_command = path
Erase m_paramaters
End Property
Public Property Get command() As String
command = m_command
End Property
Public Property Get CheckForCommandNotExist() As Boolean
CheckForCommandNotExist = m_checkForCommandNotExist
End Property
Public Property Let CheckForCommandNotExist(ByVal val As Boolean)
m_checkForCommandNotExist = val
End Property
'# -------------------------------------------------------------------------#
'# methods #
'# -------------------------------------------------------------------------#
'---------------------------------------------------------------------------------------
' Procedure : AddParamater
' Purpose : Adds a paramater.
' Quote handling is based on the fact that many cmd's will fail if file
' paramaters are not surrounded by quotes *IF* they have a space in the file
' name or path.
' eQuote_Normal will correct this.
' eQuote_ForceNone is for if your paramater has spaces but you do not want it
' surrounded by quotes. Useful for switches like -f 37.
' eQuote_ForceQuotes surrounds the paramater with quotes no matter what.
' Errors : BlankParamater
'---------------------------------------------------------------------------------------
'
Public Sub AddParamater(paramater As String, Optional ForceQuotes As eQuote = eQuote_Normal)
Const vbQuote = """"
Dim AddQuotes As Boolean
ErrorCheck_BlankParamater "AddParamater", (paramater = "")
ReDim Preserve m_paramaters(1 To ParamaterCount + 1) As String
If ForceQuotes = eQuote_ForceQuotes Then
AddQuotes = True
ElseIf ForceQuotes = eQuote_ForceNone Then
AddQuotes = False
Else ' eQuote_Normal
If InStr(1, paramater, " ") > 0 Then AddQuotes = True
End If
If AddQuotes Then
m_paramaters(ParamaterCount) = Space(Len(paramater) + 2)
Mid(m_paramaters(ParamaterCount), 1, 1) = vbQuote
Mid(m_paramaters(ParamaterCount), Len(m_paramaters(ParamaterCount)), 1) = vbQuote
Mid(m_paramaters(ParamaterCount), 2, Len(paramater)) = paramater
Else
m_paramaters(ParamaterCount) = paramater
End If
End Sub
'---------------------------------------------------------------------------------------
' Procedure : ErrNum
' Purpose : Returns the error number for the enumerated error at run-time.
' Errors : None
'---------------------------------------------------------------------------------------
'
Public Function ErrNum(Error As ErrorRunApp)
ErrNum = vbObjectError + Error
End Function
'---------------------------------------------------------------------------------------
' Procedure : RunApp
' Purpose : Run an application, returning immediately to the caller.
' Errors : CommandNotFound_ShellCommand, UnhandledError
'---------------------------------------------------------------------------------------
'
Public Sub RunApp(Optional cmd As String, Optional intMode As VbAppWinStyle = VbAppWinStyle. _
vbHide)
On Error GoTo errHandler
Dim hInstance As Long
Dim m_command As String
If cmd "" Then
m_command = cmd
Else
m_command = BuildCommand
End If
hInstance = shell(m_command, intMode)
exitRoutine:
Exit Sub
errHandler:
Select Case Err.Number
Case ErrFileNotFound
ErrorCheck_CommandNotFound_ShellCommand "RunApp"
Case Else
ErrorCheck_UnhandledError "RunApp", Err
End Select
Resume exitRoutine
End Sub
'---------------------------------------------------------------------------------------
' Procedure : RunAppWait
' Purpose : Run an application, waiting for its completion before returning to the caller.
' Errors : CommandNotFound_ShellCommand, ApiFailure, UnhandledError
'---------------------------------------------------------------------------------------
'
Public Sub RunAppWait(Optional cmd As String, Optional intMode As VbAppWinStyle = VbAppWinStyle. _
vbHide)
On Error GoTo errHandler
Dim hInstance As Long
Dim hProcess As Long
Dim lngRetval As Long
Dim lngExitCode As Long
Dim m_command As String
Dim ErrorDesc As String
If cmd "" Then
m_command = cmd
Else
m_command = BuildCommand
End If
hInstance = shell(m_command, intMode)
hProcess = OpenProcess(PROCESS_QUERY_INFORMATION Or SYNCHRONIZE, True, hInstance)
If ApiErrorChecker("OpenProcess", hProcess, Err.LastDllError, ErrorDesc) Then
ErrorCheck_ApiFailure "RunAppWait", ErrorDesc
End If
Do
lngRetval = GetExitCodeProcess(hProcess, lngExitCode)
If ApiErrorChecker("GetExitCodeProcess", lngRetval, Err.LastDllError, ErrorDesc) Then
ErrorCheck_ApiFailure "RunAppWait", ErrorDesc
End If
DoEvents
Loop Until lngExitCode STILL_ACTIVE
exitRoutine:
Exit Sub
errHandler:
Select Case Err.Number
Case ErrFileNotFound
ErrorCheck_CommandNotFound_ShellCommand "RunAppWait"
Case Else
'ApiFailure will detour through here, but will still return the correct #
ErrorCheck_UnhandledError "RunAppWait", Err
End Select
Resume exitRoutine
End Sub
'---------------------------------------------------------------------------------------
' Procedure : RunAppWait_CaptureOutput
' Purpose : Runs an application, waiting for its completion before returning to the
' caller. Screen output is captured and returned to the caller.
' Errors : ApiFailure, UnhandledError
'---------------------------------------------------------------------------------------
'
Public Function RunAppWait_CaptureOutput(Optional cmd As String) As String
On Error GoTo errHandler
Dim pa As SECURITY_ATTRIBUTES
Dim pra As SECURITY_ATTRIBUTES
Dim tra As SECURITY_ATTRIBUTES
Dim si As STARTUPINFO
Dim pi As PROCESS_INFORMATION
Dim retVal As Long
Dim command As String
Dim ErrorDesc As String
Dim hRead As Long ' stdout + stderr
Dim hWrite As Long
Dim bAvail As Long ' pipe bytes available (PeekNamedPipe)
Dim bRead As Long ' pipe bytes fetched (ReadFile)
Dim bString As String ' our buffer
If cmd "" Then
command = cmd
Else
command = BuildCommand
End If
pa.nLength = Len(pa)
pa.bInheritHandle = 1
pra.nLength = Len(pra)
tra.nLength = Len(tra)
retVal = CreatePipe(hRead, hWrite, pa, BUFSIZE)
If ApiErrorChecker("CreatePipe", retVal, Err.LastDllError, ErrorDesc) Then
ErrorCheck_ApiFailure "RunAppWait_CaptureOutput", ErrorDesc
End If
With si
.cb = Len(si)
GetStartupInfo si
.dwFlags = STARTF_USESHOWWINDOW Or STARTF_USESTDHANDLES
.wShowWindow = SW_HIDE
.hStdOutput = hWrite
.hStdError = hWrite
End With
pra.bInheritHandle = 0
tra.bInheritHandle = 0
retVal = CreateProcess(vbNullString, command, pra, tra, 1, 0&, ByVal 0&, vbNullString, si, _
pi)
If ApiErrorChecker("CreateProcess", retVal, Err.LastDllError, ErrorDesc) Then
CloseHandle hWrite
CloseHandle hRead
ErrorCheck_ApiFailure "RunAppWait_CaptureOutput", ErrorDesc
End If
Do While PeekNamedPipe(hRead, ByVal 0, 0, ByVal 0, bAvail, ByVal 0)
DoEvents
If bAvail Then
bString = String(bAvail, 0)
ReadFile hRead, bString, bAvail, bRead, ByVal 0&
bString = Left(bString, bRead)
RunAppWait_CaptureOutput = RunAppWait_CaptureOutput & bString
CloseHandle hWrite
End If
Loop
CloseHandle hRead
CloseHandle pi.hThread
CloseHandle pi.hProcess
exitRoutine:
Exit Function
errHandler:
Select Case Err.Number
Case Else
'ApiFailure will detour through here, but will still return the correct #
ErrorCheck_UnhandledError "RunAppWait_CaptureOutput", Err
End Select
Resume exitRoutine
End Function
'# -----------------------------------------------------------------------------#
'# private routines #
'# -----------------------------------------------------------------------------#
'---------------------------------------------------------------------------------------
' Procedure : ApiErrorChecker
' Purpose : Follows the convention that api's have failed if they return NULL (0).
' If the api returned an error code it will format an error message and
' return true. Gets error messages from FormatMessage api.
' Errors : None
'---------------------------------------------------------------------------------------
'
Private Function ApiErrorChecker(ApiName As String, ReturnCode As Long, ErrorCode As Long, _
ByRef ErrorDesc As String) As Boolean
Const MaxBuf = 260
Dim lngRetval As Long
'The api did not fail
If ReturnCode > 0 Then Exit Function
If ErrorCode = 0 Then
'The api failed but no error given...
'We can assume no error?
Exit Function
Else
ErrorDesc = Space(MaxBuf)
lngRetval = FormatMessage(FormatMessageDwFlags, 0&, ErrorCode, 0&, ErrorDesc, Len( _
ErrorDesc), 0&)
ErrorDesc = Left$(ErrorDesc, lngRetval)
ErrorDesc = Replace(ApiName & " exited with error code({0}): " & ErrorDesc, "{0}", _
ErrorCode)
End If
ApiErrorChecker = True
End Function
'---------------------------------------------------------------------------------------
' Procedure : BuildCommand
' Purpose : Returns the command with any paramaters attached to the end.
' Errors : NoCommand
'---------------------------------------------------------------------------------------
'
Private Function BuildCommand() As String
Dim length As Long
Dim s As String
ErrorCheck_NoCommand "BuildCommand", (command = "")
If ParamaterCount = 0 Then
length = Len(command)
Else
s = BuildParamaters
length = Len(command) + Len(s) + 1
End If
BuildCommand = Space(length)
Mid(BuildCommand, 1, Len(command)) = command
If s "" Then Mid(BuildCommand, Len(command) + 2, Len(s)) = s
End Function
'---------------------------------------------------------------------------------------
' Procedure : BuildParamaters
' Purpose : Returns paramaters with spaces in between or a null string if no paramaters.
' Errors : None
'---------------------------------------------------------------------------------------
'
Private Function BuildParamaters() As String
Dim length As Long
Dim s As Variant
If ParamaterCount = 0 Then
BuildParamaters = ""
Exit Function
End If
For Each s In m_paramaters
length = length + Len(s)
Next
If ParamaterCount > 1 Then length = length + ParamaterCount - 1
BuildParamaters = Space(length)
length = 1
For Each s In m_paramaters
Mid(BuildParamaters, length, Len(s)) = s
length = length + Len(s) + 1
Next
End Function
'---------------------------------------------------------------------------------------
' Procedure : FileExists
' Purpose : Uses windows API to determine if the file (or folder) exists.
' Errors : None
'---------------------------------------------------------------------------------------
'
Private Function FileExists(path As String) As Boolean
FileExists = PathFileExists(path)
End Function
'---------------------------------------------------------------------------------------
' Procedure : ParamaterCount
' Purpose : Returns the number of paramaters stored. m_paramaters() is base 1
' Errors : None
'---------------------------------------------------------------------------------------
'
Private Function ParamaterCount() As Long
On Error GoTo errHandler
ParamaterCount = UBound(m_paramaters)
exitRoutine:
Exit Function
errHandler:
Err.Clear
Resume exitRoutine
End Function
Gruß Andi