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