AW: Tabelle als Bild
08.03.2023 19:28:02
Nepumuk
Hallo Udo,
teste mal das:
Option Explicit
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 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 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 GUID_IPICTUREDISP As String = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Private Const FORMAT_ID_JPG As String = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}"
Private llngptrCopy As LongPtr
Public Sub SaveRange()
Dim objPicture As IPictureDisp
Dim objRange As Range
Dim objImageFile As Object, objImageProcess As Object
Dim strPicturePath As String, strTempPicturePath As String
Dim lngptrhPic As LongPtr
Dim vntWorksheet As Variant
strTempPicturePath = Environ$("TMP") & "\Temp.bmp"
Set objImageFile = CreateObject(Class:="WIA.ImageFile")
Set objImageProcess = CreateObject(Class:="WIA.ImageProcess")
With objImageProcess
Call .Filters.Add(FilterID:=.FilterInfos("Convert").FilterID)
.Filters.Item(1).Properties("FormatID") = FORMAT_ID_JPG
.Filters.Item(1).Properties("Quality") = 100
End With
With ThisWorkbook
For Each vntWorksheet In Array(.Worksheets("Tabelle1")) ', .Worksheets("Tabelle2"), .Worksheets("Tabelle3")) 'Anpassen !!!
With vntWorksheet
Set objRange = .Range(.PageSetup.PrintArea)
strPicturePath = ThisWorkbook.Path & "\" & .Range("A1").Text & ".jpg"
End With
Call OpenClipboard(CLngPtr(Application.hwnd))
Call EmptyClipboard
Call CloseClipboard
On Error Resume Next
Do
Call objRange.CopyPicture(Appearance:=xlScreen, Format:=xlBitmap)
If Err.Number = 0 Then Exit Do
Call Err.Clear
DoEvents
Loop
Do
Set objPicture = Paste_Picture(lngptrhPic)
If Not objPicture Is Nothing Then Exit Do
Err.Clear
DoEvents
Loop
On Error GoTo 0
Call SavePicture(Picture:=objPicture, Filename:=strTempPicturePath)
Call objImageFile.LoadFile(Filename:=strTempPicturePath)
Set objImageFile = objImageProcess.Apply(Source:=objImageFile)
If Dir$(PathName:=strPicturePath) > vbNullString Then Call Kill(PathName:=strPicturePath)
Call objImageFile.SaveFile(Filename:=strPicturePath)
Call Kill(PathName:=strTempPicturePath)
Call DeleteObject(lngptrhPic)
Next
End With
Set objPicture = Nothing
Set objImageProcess = Nothing
Set objImageFile = Nothing
End Sub
Private Function Paste_Picture(ByRef prlngptrhPic As LongPtr) As IPictureDisp
Dim lngReturn As Long, lngptrPointer As LongPtr
If CBool(IsClipboardFormatAvailable(CF_BITMAP)) Then
lngReturn = OpenClipboard(CLngPtr(Application.hwnd))
If lngReturn = 1 Then
lngptrPointer = GetClipboardData(CF_BITMAP)
prlngptrhPic = CopyImage(lngptrPointer, _
IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
Call CloseClipboard
If lngptrPointer > 0 Then Set Paste_Picture = _
Create_Picture(prlngptrhPic, 0&)
End If
End If
End Function
Private Function Create_Picture( _
ByVal pvlngptrhPic As LongPtr, _
ByVal pvlngptrhPal 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 = LenB(udtPicInfo)
.Type = PICTYPE_BITMAP
.hPic = pvlngptrhPic
.hPal = pvlngptrhPal
End With
Call OleCreatePictureIndirect(udtPicInfo, _
udtID_IDispatch, 0, objPicture)
Set Create_Picture = objPicture
Set objPicture = Nothing
End Function
Gruß
Nepumuk