AW: Screenshot von PDF erstellen und einfüge
07.05.2020 08:23:41
PDF
Guten Morgen Karl Heinz,
erst einmal noch mal Danke, kann ich gar nicht oft genug sagen.
Ich habe deinen Code eben gerade getestet, und er fügt nur einen Screenshot ein. Egal wie viel Seiten die PDF hat. Bei der GetPageCount von die kommt 0 raus wenn ich das per Hand durch gehe. Kann das eventuell an der PDF Version liegen? Meine ist 1.6 wenn ich das mit Txt Editor öffne.
Danke für die Erklärung das die Konstanten rein müssen, ja so ist es Logisch, gibt es eine Liste welche &H für welche Taste ist?
Meine komplette Datei darf ich leider nicht Hochladen, könnte nur die Sachen um die es geht Anonymisieren aber dann bringt es glaube ich nichts mehr. Weil letztlich gibt es für jede PDF einen Reiter wo die PDF eingefügt werden. Und in einem Modul ist dann mein Code, da kann ich hier auch meinen Code reinkopieren, ich denke das hat den selben Effekt. Ansonsten sag noch mal bescheid.
Deshalb habe ich in meinem Code die PDF mal nach den Reitern umbenannt und lasse Ihn die so Automatisch suchen.
Mit folgendem Code funktioniert das jetzt auf jeden Fall wie gedacht.
Option Explicit
Const VK_NEXT = &H22
Const VK_HOME = &H24
Private Declare PtrSafe Sub keybd_event Lib "user32" ( _
ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, _
ByVal dwExtraInfo As Long)
'StartUp
Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" ( _
ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As LongPtr
'DC-Funktionen
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" ( _
ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" ( _
ByVal hdc As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" ( _
ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function BitBlt Lib "gdi32" (ByVal hDestDC As LongPtr, _
ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, _
ByVal nHeight As Long, ByVal hSrcDC As LongPtr, ByVal xSrc As Long, _
ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function StretchBlt Lib "gdi32" ( _
ByVal hdc As LongPtr, ByVal x As Long, ByVal y As Long, _
ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As LongPtr, _
ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, _
ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare PtrSafe Function DeleteDC Lib "gdi32" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function ReleaseDC Lib "user32" ( _
ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
'Window-Funktionen
Private Declare PtrSafe Function SetForegroundWindow Lib "user32" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetForegroundWindow Lib "user32" () As LongPtr
Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function PostMessage Lib "user32" Alias "PostMessageA" ( _
ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, _
ByVal lParam As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As _
RECT) As Long
Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Clipboard-Funktionen
Private Declare PtrSafe Function OpenClipboard Lib "user32" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32" ( _
ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Const SRCCOPY = &HCC0020
Private Const SW_MAXIMIZE = 3
Private Const WM_CLOSE = &H10
Private Const CF_BITMAP = 2
Sub PDF_ScreenShot()
'öffnet eine PDF-Datei und erstellt einen Screenshot, fügt diesen in Excel ein
Dim rZiel As Range, rRette As Range, tRect As RECT
Dim srcDC As LongPtr, trgDC As LongPtr, hBmp As LongPtr, hwnd As LongPtr
Dim iLeft As Long, iTop As Long, iWidth As Long, iHeight As Long, AnzahlScreens As Long
Dim i, j As Integer
Dim sPathFile As String, Seite As Long
Dim WS As Worksheet
Dim RTop, RDown, RBreite
'Seitenzahlen der PDF in ein Array
Const FOLDER_PATH = "C:\PDF einfügen test\" 'Ordner in dem sich die PDF's nefinden
Dim strFileName As String
Dim lngRow As Long
Dim MyArray(2, 1) As Variant
ActiveWorkbook.Unprotect
With Application
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
.DisplayStatusBar = True
End With
strFileName = Dir$(FOLDER_PATH & "*.pdf")
Do Until strFileName = vbNullString
Application.StatusBar = strFileName
MyArray(lngRow, 0) = strFileName
MyArray(lngRow, 1) = GetPageCount(FOLDER_PATH & strFileName)
lngRow = lngRow + 1
strFileName = Dir$
Loop
With Application
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
.StatusBar = False
End With
'Zugehöriges Tabellenblatt auswählen ---> wo PDF eingefügt werden soll
For j = 0 To 2
Set WS = Worksheets(Left(MyArray(j, 0), Len(MyArray(j, 0)) - 4))
Seite = MyArray(j, 1)
AnzahlScreens = 0
'##### Hier die Quell/Zieldaten einstellen #####
sPathFile = "C:\Users\sven.roettjer\Documents\Bilder einfügen test\" & MyArray(j, 0) 'PDF- _
Datei mit Pfad ermitteln
If Dir$(sPathFile) "" Then
ShellExecute 0&, "Open", sPathFile, 0, 0, SW_MAXIMIZE 'Datei öffnen im _
Vollbildmodus
'Warten bis PDF-Laden fertig und Handle ermitteln
i = 0
Do
Sleep 100: i = i + 1
hwnd = FindWindow("AcrobatSDIWindow", vbNullString) 'Windowhandel ermitteln
If i > 100 Then
MsgBox "Timeout: Prozedur wird abgebrochen!", vbCritical, "PDF-Screenshot"
Exit Sub
End If
If hwnd 0 Then
SetForegroundWindow hwnd
Sleep 100
If GetForegroundWindow() = hwnd Then Exit Do 'PDF fertig geladen
End If
Loop
Sleep 500
GetWindowRect hwnd, tRect 'Windowkoordinaten holen
'##### Hier die Ausschnittsdaten einstellen #####
iLeft = 605: iTop = 140
iWidth = tRect.Right - iLeft - 700
iHeight = tRect.Bottom - iTop - 30
For i = 1 To Seite 'Anzahl Screenshots
'Jetzt den Screenshot machen
srcDC = GetDC(GetDesktopWindow())
trgDC = CreateCompatibleDC(srcDC) 'Device Context _
erstellen
hBmp = CreateCompatibleBitmap(srcDC, iWidth, iHeight) 'Bildausschnitt _
zuordnen
SelectObject trgDC, hBmp 'Bild auswählen
BitBlt trgDC, 0, 0, iWidth, iHeight, srcDC, iLeft, iTop, SRCCOPY 'Pixel kopieren
OpenClipboard 0&: EmptyClipboard 'Zwischenablage öffnen
SetClipboardData 2, hBmp: CloseClipboard 'Bild rein und _
Zwischenablage schließen
DeleteDC trgDC: ReleaseDC hBmp, srcDC 'Device Context schließ _
en
keybd_event VK_NEXT, 0&, 0&, 0&
'Bild ist jetzt in Zwischenablage
If IsClipboardFormatAvailable(CF_BITMAP) Then 'Screenshot einfügen
With WS
.Unprotect
.Activate
.Range("H2").Interior.Color = xlNone
.Paste
RBreite = Range("A:H").Width
If TypeName(Selection) = "Picture" Then
If AnzahlScreens = 0 Then
RDown = 56
RTop = 11
With Selection
If (Range(Cells(RTop, 1), Cells(RDown, 1)).Height / (RBreite - 50)) "" Then
ActiveCell.Clear
MsgBox "Kein Bild in der Zwischenablage"
End If
End If
End With
'Kein Bitmap in Zwischenablage
Else
MsgBox "Es wurde kein Bild kopiert!", vbCritical, "PDF-Screenshot"
End If
Next i
'Kein Bitmap in Zwischenablage
PostMessage hwnd, WM_CLOSE, 0&, 0& 'PDF-Anwendung schließen
Else
'Keine Datei gefunden
MsgBox "Die PDF-Datei wurde nicht gefunden!", vbCritical, "PDF-Screenshot"
End If
Next j
Exit Sub
Fehler:
MsgBox "Es ist der Fehler '" & Error & "' aufgetreten!", vbCritical, "PDF-Screenshot"""
End Sub
Private Function GetPageCount( _
ByVal pvstrFileName As String) As Long
Dim strText As String
Dim strLinearized As String, astrCount() As String
Dim ialngIndex As Long
Dim objFileSystemObject As Object, objTextFile As Object
Dim objRegEx As Object, objMatch As Object, objItem As Object
Dim blnFound As Boolean
GetPageCount = -1
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFileSystemObject.OpenTextFile(pvstrFileName, 1, False, 0)
Do Until objTextFile.AtEndOfStream
strText = objTextFile.ReadLine
strText = Replace(strText, vbLf, vbNullString)
If CBool(InStr(1, strText, "/Linearized")) Then
If Len(strText) > 20 Then
strLinearized = strText
blnFound = True
Exit Do
End If
End If
If CBool(InStr(1, strText, "/Count ")) Then
ReDim Preserve astrCount(ialngIndex)
astrCount(ialngIndex) = strText
ialngIndex = ialngIndex + 1
blnFound = True
End If
Loop
Call objTextFile.Close
Set objTextFile = Nothing
Set objFileSystemObject = Nothing
If blnFound Then
Set objRegEx = CreateObject("VBScript.RegExp")
With objRegEx
.MultiLine = True
.Global = True
.IgnoreCase = False
If strLinearized vbNullString Then
.Pattern = "\/N.?(\d+).?"
Set objMatch = .Execute(strLinearized)
If objMatch.Count > 0 Then _
GetPageCount = CLng(objMatch(0).SubMatches(0))
Else
If ialngIndex = 1 Then
.Pattern = "\/Count.?(\d+)"
Set objMatch = .Execute(astrCount(0))
If objMatch.Count = 1 Then
GetPageCount = CLng(objMatch(0).SubMatches(0))
Else
For Each objItem In objMatch
GetPageCount = WorksheetFunction.Max( _
GetPageCount, CLng(objItem.SubMatches(0)))
Next
End If
Else
.Pattern = "\/Count.?(-?\d+)"
For ialngIndex = 0 To UBound(astrCount)
Set objMatch = .Execute(astrCount(ialngIndex))
GetPageCount = WorksheetFunction.Max( _
GetPageCount, CLng(objMatch(0).SubMatches(0)))
Next
End If
End If
End With
Set objMatch = Nothing
Set objRegEx = Nothing
End If
End Function
Wie schon erwähnt habe ich noch nicht soviel Erfahrung, falls dir was auffältt wie ich den Code eleganter oder besser Formulieren kann sag gerne Bescheid.
Den Teil werde ich noch optimieren:
If (Range(Cells(RTop, 1), Cells(RDown, 1)).Height / (RBreite - 50))
Das war noch aus einem anderen Code wo ich Bilder einfüge wo die Größe vorher nicht bekannt ist. Das brauche ich ja jetzt nicht das ja durch die Skalierung die Größe des Screenshots immer gleich ist. Das ist mir bewusst.
Der Vorteil an der Countfunktion ist auch das ich so gleich die Dateinamen mit in dem Array habe. Falls du noch eine neue Version von deinem Code hast der kürzer und einfacher ist bin ich auch darauf gespannt.
Ansonsten würde mich halt nur noch interessieren wie genau ich das mache mit dem auf Auflösung reagieren. Hab ich ja noch nie gemacht. Ist jetzt auch nicht so wichtig und eilt definitiv nicht aber würde mich durchaus interessieren. Dann wäre es wirklich ein Makro was ich bedenkenlos überall nutzen kann.
Gruß Sven
