Thema Datum  Von Nutzer Rating
Antwort
Rot VBA mit Windos API
10.05.2016 11:33:07 Simon
NotSolved
11.05.2016 10:37:29 SJ
NotSolved

Ansicht des Beitrags:
Von:
Simon
Datum:
10.05.2016 11:33:07
Views:
1466
Rating: Antwort:
  Ja
Thema:
VBA mit Windos API
1
 
1
 
1
Hallo zuasmmen,

ich habe folgendes Problem. ich möchte ein PDF nach etwas durchsuchen. Wenn ich aber die PDF Datei nach Excel
zurückkonvertiere zerreist es mir die Datei komplett und ich komme mit Suchschleifen nicht mehr weiter.

Mein Plan ist nun die PDF Datei zu öffnen, nach einem bestimmten Begriff zu durchsuchen (diesen am besten noch markieren),
in den Vollbildmodus gehen und hiervon einen Screenshot zu machen und diesen in Excel einzufügen.

Für einen Teil dieses Plans habe ich im Internet einen Code gefunden, der mein Können allerdings bei Weitem übersteigt
und ich daher keine Ahnung hab, wo ich ansetzten könnte, um diesen auf meine Bedürfnisse zu erweitern.
Bis jetzt öffnet der Code die PDF und macht von der ersten Seite einen Screenshot und fügt diesen in das Excel-Datenblatt
ein.

Hat jemand eine Idee, wie ich den Code anpassen kann? Vielen Dank schonmal für jede Hilfe! Gruß Simon

 

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
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
Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds As Long)
Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function ShowWindow Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByVal nCmdShow As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpdwProcessId As Long) As Long
Private Declare Function AllowSetForegroundWindow Lib "user32.dll" ( _
    ByVal dwProcessId As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal hObject As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal iCapabilitiy As Long) As Long
Private Declare Function GetSystemPaletteEntries Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal wStartIndex As Long, _
    ByVal wNumEntries As Long, _
    ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare Function CreatePalette Lib "gdi32.dll" ( _
    ByRef lpLogPalette As LOGPALETTE) As Long
Private Declare Function SelectPalette Lib "gdi32.dll" ( _
    ByVal hdc As Long, _
    ByVal hPalette As Long, _
    ByVal bForceBackground As Long) As Long
Private Declare Function RealizePalette Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long
Private Declare Function BitBlt Lib "gdi32.dll" ( _
    ByVal hDestDC As Long, _
    ByVal x As Long, _
    ByVal y As Long, _
    ByVal nWidth As Long, _
    ByVal nHeight As Long, _
    ByVal hSrcDC As Long, _
    ByVal xSrc As Long, _
    ByVal ySrc As Long, _
    ByVal dwRop As Long) As Long
Private Declare Function GetWindowRect Lib "user32.dll" ( _
    ByVal hwnd As Long, _
    ByRef lpRect As RECT) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" ( _
    ByVal hdc As Long) As Long
Private Declare Function GetDC Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare Function OpenClipboard Lib "user32.dll" ( _
    ByVal hwnd As Long) As Long
Private Declare Function SetClipboardData Lib "user32.dll" ( _
    ByVal wFormat As Long, _
    ByVal hMem As Long) As Long
Private Declare Function IsClipboardFormatAvailable Lib "user32.dll" ( _
    ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare Function CloseClipboard Lib "user32.dll" () As Long
 
Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
 
Private Type PALETTEENTRY
    peRed As Byte
    peGreen As Byte
    peBlue As Byte
    peFlags As Byte
End Type
 
Private Type LOGPALETTE
    palVersion As Integer
    palNumEntries As Integer
    palPalEntry(255) As PALETTEENTRY
End Type
 
Private Const RASTERCAPS = 38
Private Const RC_PALETTE = &H100
Private Const SIZEPALETTE = 104
Private Const SRCCOPY = &HCC0020
Private Const GC_CLASSNAMEADOBE = "AcrobatSDIWindow"
Private Const SW_MAXIMIZE = 3
Private Const WM_CLOSE = &H10
Private Const CF_BITMAP = 2
 
Public Sub Screenshot()
 
    Const FILE_PATH = "C:\Dokument.pdf"
 
    Dim lngHwndPDF As Long, lngTempDC As Long
    Dim udtRect As RECT
 
    If Dir$(FILE_PATH) <> vbNullString Then
 
        Call ShellExecute(Application.hwnd, "open", FILE_PATH, _
            vbNullString, vbNullString, SW_MAXIMIZE)
 
        If CaptureAdobeWindow(lngHwndPDF) Then
 
            Call GetWindowRect(lngHwndPDF, udtRect)
 
            Call OpenClipboard(Application.hwnd)
            Call EmptyClipboard
            Call SetClipboardData(CF_BITMAP, DCToPicture(udtRect))
            Call CloseClipboard
         
            If IsClipboardFormatAvailable(CF_BITMAP) Then
 
                Call PostMessage(lngHwndPDF, WM_CLOSE, 0&, 0&)
 
                With Tabelle1
                    .Select
                    .Range("B1").Select
                    .Paste
                    .Range("A1").Select
                End With
 
            Else
                MsgBox "Fehler beim schreiben des Bildes in die Zwischenablage.", _
                    vbCritical, "Programmabbruch"
            End If
        Else
            MsgBox "Fenster des PDF-Readers nicht gefunden.", vbCritical, "Programmabbruch"
        End If
    Else
        MsgBox "Datei ''" & FILE_PATH & "'' nicht gefunden.", vbCritical, "Programmabbruch"
    End If
End Sub
 
Private Function CaptureAdobeWindow(ByRef prlngHwndPDF As Long) As Boolean
 
    Dim lngProcessID As Long, lngSumActivity As Long
    Dim lngWaitForWindow As Long, lngWaitForProcess As Long
    Dim objProcess As Object, objItem As Object
 
    For lngWaitForWindow = 1 To 20
 
        prlngHwndPDF = FindWindow(GC_CLASSNAMEADOBE, vbNullString)
        If prlngHwndPDF <> 0 Then
 
            lngProcessID = GetWindowThreadProcessId(prlngHwndPDF, ByVal 0&)
            Call AllowSetForegroundWindow(lngProcessID)
            Call SetForegroundWindow(prlngHwndPDF)
            Call ShowWindow(prlngHwndPDF, SW_MAXIMIZE)
 
            For lngWaitForProcess = 1 To 20
 
                Set objProcess = GetObject("winmgmts:").InstancesOf( _
                    "Win32_PerfFormattedData_PerfProc_Process WHERE Name LIKE 'AcroRd32%'")
 
                For Each objItem In objProcess
                    lngSumActivity = lngSumActivity + objItem.PercentPrivilegedTime + _
                        objItem.PercentProcessorTime + objItem.PercentUserTime
                Next
 
                If lngSumActivity = 0 Then
                    CaptureAdobeWindow = True
                    Exit For
                End If
 
                lngSumActivity = 0
 
                Call Sleep(500)
 
            Next
        End If
 
        If CaptureAdobeWindow Then Exit For
 
        Call Sleep(250)
 
    Next
End Function
 
Private Function DCToPicture( _
    ByRef prudtRect As RECT) As Long
 
    Dim lngLeftSrc As Long, lngTopSrc As Long, lngWidthSrc As Long
    Dim lnghDCMemory As Long, lnghBmp As Long, lngHeightSrc As Long
    Dim lnghPal As Long, lnghPalPrev As Long, lnghBmpPrev As Long
    Dim lngRasterCapsScrn As Long, lnghDCScr As Long
    Dim lngHasPaletteScrn As Long, lngPaletteSizeScrn As Long
    Dim udtLogPal As LOGPALETTE
     
    lngLeftSrc = prudtRect.Left
    lngTopSrc = prudtRect.Top
    lngWidthSrc = prudtRect.Right - prudtRect.Left
    lngHeightSrc = prudtRect.Bottom - prudtRect.Top
 
    lnghDCScr = GetDC(0&)
             
    lnghDCMemory = CreateCompatibleDC(lnghDCScr)
    lnghBmp = CreateCompatibleBitmap(lnghDCScr, lngWidthSrc, lngHeightSrc)
    lnghBmpPrev = SelectObject(lnghDCMemory, lnghBmp)
    lngRasterCapsScrn = GetDeviceCaps(lnghDCScr, RASTERCAPS)
    lngHasPaletteScrn = lngRasterCapsScrn And RC_PALETTE
    lngPaletteSizeScrn = GetDeviceCaps(lnghDCScr, SIZEPALETTE)
 
    If lngHasPaletteScrn And (lngPaletteSizeScrn = &H100) Then
        udtLogPal.palVersion = &H300
        udtLogPal.palNumEntries = &H100
        Call GetSystemPaletteEntries(lnghDCScr, 0&, &H100, udtLogPal.palPalEntry(0))
        lnghPal = CreatePalette(udtLogPal)
        lnghPalPrev = SelectPalette(lnghDCMemory, lnghPal, 0)
        Call RealizePalette(lnghDCMemory)
    End If
 
    Call BitBlt(lnghDCMemory, 0, 0, lngWidthSrc, lngHeightSrc, _
        lnghDCScr, lngLeftSrc, lngTopSrc, SRCCOPY)
 
    lnghBmp = SelectObject(lnghDCMemory, lnghBmpPrev)
 
    If lngHasPaletteScrn And (lngPaletteSizeScrn = 256) Then _
        lnghPal = SelectPalette(lnghDCMemory, lnghPalPrev, 0)
 
    Call DeleteDC(lnghDCMemory)
     
    DCToPicture = lnghBmp
 
End Function

 


Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot VBA mit Windos API
10.05.2016 11:33:07 Simon
NotSolved
11.05.2016 10:37:29 SJ
NotSolved