AW: VBA Code zum PDF laden.....
15.06.2022 13:11:16
Nepumuk
Hallo Ralf,
teste mal:
Option Explicit
Private Declare PtrSafe Function ShellExecuteA Lib "shell32.dll" ( _
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
Private Declare PtrSafe Function OleCreatePictureIndirect Lib "oleaut32.dll" ( _
ByRef PicDesc As PICT_DESC, _
ByRef RefIID As GUID, _
ByVal fPictureOwnsHandle As LongPtr, _
ByRef IPic As IPicture) As LongPtr
Private Declare PtrSafe Function CopyImage Lib "user32.dll" ( _
ByVal handle As LongPtr, _
ByVal un1 As Long, _
ByVal n1 As Long, _
ByVal n2 As Long, _
ByVal un2 As Long) As LongPtr
Private Declare PtrSafe Function IsClipboardFormatAvailable Lib "user32.dll" ( _
ByVal wFormat As Long) As Long
Private Declare PtrSafe Function OpenClipboard Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function GetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32.dll" ( _
ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32.dll" ( _
ByVal lpsz As Any, _
ByRef pCLSID As GUID) As Long
Private Declare PtrSafe Function EmptyClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function CloseClipboard Lib "user32.dll" () As Long
Private Declare PtrSafe Function GetDC Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nIndex As Long) As Long
Private Declare PtrSafe Function MulDiv Lib "kernel32.dll" ( _
ByVal nNumber As Long, _
ByVal nNumerator As Long, _
ByVal nDenominator As Long) As Long
Private Declare PtrSafe Function GetDesktopWindow Lib "user32.dll" () As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function GetSystemPaletteEntries Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal wStartIndex As Long, _
ByVal wNumEntries As Long, _
ByRef lpPaletteEntries As PALETTEENTRY) As Long
Private Declare PtrSafe Function CreatePalette Lib "gdi32.dll" ( _
ByRef lpLogPalette As LOGPALETTE) As LongPtr
Private Declare PtrSafe Function SelectPalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr, _
ByVal hPalette As LongPtr, _
ByVal bForceBackground As Long) As LongPtr
Private Declare PtrSafe Function RealizePalette Lib "gdi32.dll" ( _
ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function BitBlt Lib "gdi32.dll" ( _
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 GetWindowRect Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByRef lpRect As RECT) As Long
Private Declare PtrSafe Function SetClipboardData Lib "user32.dll" ( _
ByVal wFormat As Long, _
ByVal hMem As LongPtr) As LongPtr
Private Declare PtrSafe Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Declare PtrSafe Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As LongPtr
Private Declare PtrSafe Function GetWindowThreadProcessId Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByRef lpdwProcessId As Long) As Long
Private Declare PtrSafe Function AllowSetForegroundWindow Lib "user32.dll" ( _
ByVal dwProcessId As LongPtr) As Long
Private Declare PtrSafe Function SetForegroundWindow Lib "user32.dll" ( _
ByVal hwnd As LongPtr) As Long
Private Declare PtrSafe Function ShowWindow Lib "user32.dll" ( _
ByVal hwnd As LongPtr, _
ByVal nCmdShow As Long) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICT_DESC
Size As Long
Type As Long
hPic As LongPtr
hPal As LongPtr
End Type
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 SRCCOPY As Long = &HCC0020
Private Const SIZEPALETTE As Long = 104
Private Const RC_PALETTE As Long = &H100
Private Const RASTERCAPS As Long = 38
Private Const LOGPIXELS_X As Long = 88&
Private Const LOGPIXELS_Y As Long = 90&
Private Const HIMETRIC_INCH As Long = 2540&
Private Const PICTYPE_BITMAP As Long = 1&
Private Const CF_BITMAP As Long = 2&
Private Const IMAGE_BITMAP As Long = 0&
Private Const LR_COPYRETURNORG As Long = &H4
Private Const SW_SHOWMAXIMIZED As Long = 3
Private Const GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Private Const GC_CLASSNAMEADOBE As String = "AcrobatSDIWindow"
Public Sub Search_PDF()
Const FOLDER_PATH As String = "T:\QP Auswertung\"
Dim strSearch As String, strFilename As String, strTempPath As String
Dim lngColumn As Long
Dim lngptrHwndPDF As LongPtr, lngptrCopy As LongPtr
Dim udtRect As RECT
Dim objShape As Shape
Dim objPicture As IPictureDisp
strSearch = Range("A1").Text 'Suchstring in Zelle. Anpassen !!!
strFilename = Dir$(FOLDER_PATH & "*" & strSearch & "*.pdf")
If strFilename = vbNullString Then
Call MsgBox("Keine passende PDF-Datei gefunden.", vbExclamation, "Hinweis")
Else
strTempPath = Environ$("TMP") & "\Picture.bmp"
lngColumn = 2
Call Close_PDF
For Each objShape In ActiveSheet.Shapes
If objShape.Type = msoPicture Then Call objShape.Delete
Next
Do Until strFilename = vbNullString
Call ShellExecuteA(0, "OPEN", FOLDER_PATH & strFilename, vbNullString, vbNullString, SW_SHOWMAXIMIZED)
If CaptureAdobeWindow(lngptrHwndPDF) Then
Call GetWindowRect(lngptrHwndPDF, udtRect)
Call OpenClipboard(Application.hwnd)
Call EmptyClipboard
Call SetClipboardData(CF_BITMAP, DCToPicture(udtRect))
Call CloseClipboard
If IsClipboardFormatAvailable(CF_BITMAP) Then
Call Close_PDF
Set objPicture = PastePicture(lngptrCopy)
Call SavePicture(objPicture, strTempPath)
Call DeleteObject(lngptrCopy)
Set objPicture = Nothing
Set objShape = ActiveSheet.Shapes.AddPicture(Filename:=strTempPath, LinkToFile:=msoFalse, _
SaveWithDocument:=msoTrue, Left:=Columns(lngColumn).Left, Top:=0, Width:=200, Height:=285)
Call ActiveSheet.Hyperlinks.Add(Anchor:=objShape, Address:=FOLDER_PATH & strFilename, ScreenTip:=strFilename)
lngColumn = lngColumn + 4
Else
MsgBox "Fehler beim schreiben des Bildes in die Zwischenablage.", vbCritical, "Programmabbruch"
Exit Do
End If
Else
MsgBox "Fenster des PDF-Readers nicht gefunden.", vbCritical, "Programmabbruch"
Exit Do
End If
strFilename = Dir$
Loop
End If
End Sub
Private Sub Close_PDF()
Dim objWMI As Object, objProcessList As Object, objProcess As Object
Set objWMI = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\cimv2")
Set objProcessList = objWMI.ExecQuery("SELECT * FROM Win32_Process WHERE Name LIKE 'Acro%'")
For Each objProcess In objProcessList
Call objProcess.Terminate(0)
Exit For
Next
Set objProcess = Nothing
Set objProcessList = Nothing
Set objWMI = Nothing
End Sub
Private Function PastePicture(ByRef prlngptrCopy As LongPtr) As IPictureDisp
Dim lngReturn As Long, lngptrPointer As LongPtr
If CBool(IsClipboardFormatAvailable(CF_BITMAP)) Then
lngReturn = OpenClipboard(CLngPtr(Application.hwnd))
If lngReturn > 0 Then
lngptrPointer = GetClipboardData(CF_BITMAP)
prlngptrCopy = CopyImage(lngptrPointer, _
IMAGE_BITMAP, 0&, 0&, LR_COPYRETURNORG)
Call CloseClipboard
If lngptrPointer 0 Then Set PastePicture = _
CreatePicture(prlngptrCopy, 0)
End If
End If
End Function
Private Function CreatePicture( _
ByVal lngptrhPic As LongPtr, _
ByVal lngptrhPal As LongPtr) As IPictureDisp
Dim udtPicInfo As PICT_DESC, udtID_IDispatch As GUID
Dim objPicture As IPictureDisp
Call CLSIDFromString(StrPtr( _
GUID_IPICTUREDISP), udtID_IDispatch)
With udtPicInfo
.Size = Len(udtPicInfo)
.Type = PICTYPE_BITMAP
.hPic = lngptrhPic
.hPal = lngptrhPal
End With
Call OleCreatePictureIndirect(udtPicInfo, _
udtID_IDispatch, 0&, objPicture)
Set CreatePicture = objPicture
Set objPicture = Nothing
End Function
Private Function DCToPicture( _
ByRef prudtRect As RECT) As LongPtr
Dim lngLeftSrc As Long, lngTopSrc As Long, lngWidthSrc As Long
Dim lngptrhDCMemory As LongPtr, lngptrhBmp As LongPtr, lngHeightSrc As Long
Dim lngptrhPal As LongPtr, lngptrhPalPrev As LongPtr, lngptrhBmpPrev As LongPtr
Dim lngRasterCapsScrn As Long, lngptrhDCScr As LongPtr
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
lngptrhDCScr = GetDC(0&)
lngptrhDCMemory = CreateCompatibleDC(lngptrhDCScr)
lngptrhBmp = CreateCompatibleBitmap(lngptrhDCScr, lngWidthSrc, lngHeightSrc)
lngptrhBmpPrev = SelectObject(lngptrhDCMemory, lngptrhBmp)
lngRasterCapsScrn = GetDeviceCaps(lngptrhDCScr, RASTERCAPS)
lngHasPaletteScrn = lngRasterCapsScrn And RC_PALETTE
lngPaletteSizeScrn = GetDeviceCaps(lngptrhDCScr, SIZEPALETTE)
If lngHasPaletteScrn And (lngPaletteSizeScrn = &H100) Then
udtLogPal.palVersion = &H300
udtLogPal.palNumEntries = &H100
Call GetSystemPaletteEntries(lngptrhDCScr, 0&, &H100, udtLogPal.palPalEntry(0))
lngptrhPal = CreatePalette(udtLogPal)
lngptrhPalPrev = SelectPalette(lngptrhDCMemory, lngptrhPal, 0)
Call RealizePalette(lngptrhDCMemory)
End If
Call BitBlt(lngptrhDCMemory, 0, 0, lngWidthSrc, lngHeightSrc, _
lngptrhDCScr, lngLeftSrc, lngTopSrc, SRCCOPY)
lngptrhBmp = SelectObject(lngptrhDCMemory, lngptrhBmpPrev)
If lngHasPaletteScrn And (lngPaletteSizeScrn = 256) Then _
lngptrhPal = SelectPalette(lngptrhDCMemory, lngptrhPalPrev, 0)
Call DeleteDC(lngptrhDCMemory)
DCToPicture = lngptrhBmp
End Function
Private Function CaptureAdobeWindow( _
ByRef prlngptrHwndPDF As LongPtr) As Boolean
Dim lngProcessID As Long, lngSumActivity As Long
Dim lngWaitForWindow As Long, lngWaitForProcess As Long
Dim objProcess As Object, objItem As Object
Call Sleep(1000)
For lngWaitForWindow = 1 To 20
prlngptrHwndPDF = FindWindowA(GC_CLASSNAMEADOBE, vbNullString)
If prlngptrHwndPDF 0 Then
lngProcessID = GetWindowThreadProcessId(prlngptrHwndPDF, ByVal 0&)
Call AllowSetForegroundWindow(lngProcessID)
Call SetForegroundWindow(prlngptrHwndPDF)
Call ShowWindow(prlngptrHwndPDF, SW_SHOWMAXIMIZED)
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
Gruß
Nepumuk