AW: Tabelle mit Fenster
08.11.2018 20:16:10
Sepp
Hallo Klaus,
in ein allgemeines Modul:
Modul Modul1
Option Explicit
'? 2015 by Nepumuk - http://www.herber.de/forum/messages/1458287.html
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
lSize As Long
lType 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}"
Sub updateImage()
Dim objImage As Object
Dim rng As Range
On Error Resume Next
ActiveSheet.OLEObjects("myImage").Delete
Set rng = ActiveWindow.VisibleRange
Set objImage = ActiveSheet.OLEObjects.Add(ClassType:="Forms.Image.1", Link:=False, _
DisplayAsIcon:=False, Left:=0, Top:=0, Width:=0, Height:=0)
With objImage
.Name = "myImage"
.Object.Picture = showRange(Range("I1:AG5"))
.Object.AutoSize = True
.Left = rng.Left + rng.Width / 2 - .Width / 2
.Top = rng.Top + rng.Height / 2 - .Height / 2
End With
Set objImage = Nothing
Set rng = Nothing
End Sub
Sub deleteImage()
On Error Resume Next
ActiveSheet.OLEObjects("myImage").Delete
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
.lSize = Len(udtPicInfo)
.lType = PICTYPE_BITMAP
.hPic = lngptrhPic
.hPal = lngptrhPal
End With
Call OleCreatePictureIndirect(udtPicInfo, udtID_IDispatch, 0&, objPicture)
Set CreatePicture = objPicture
Set objPicture = Nothing
End Function
Public Function showRange(ByRef Target As Range) As IPictureDisp
Static slngptrCopy As LongPtr
Call OpenClipboard(0&)
Call EmptyClipboard
Call CloseClipboard
If slngptrCopy <> 0 Then Call DeleteObject(slngptrCopy)
Target.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Set showRange = PastePicture(slngptrCopy)
If showRange Is Nothing Then Call MsgBox("Unabel to show range as picture", vbCritical, "Error")
End Function
Private Function SaveClipboardImage(FileName As String) As Boolean
Dim lPicType As Long, oPic As Variant
lPicType = xlBitmap
Set oPic = PastePicture(lPicType)
If oPic Is Nothing Then Exit Function
SavePicture oPic, FileName
SaveClipboardImage = True
End Function
VBA/HTML-CodeConverter, AddIn für Office 2002-2016 - in VBA geschrieben von Lukas Mosimann. Projektbetreuung:RMH Software & Media
Code erstellt und getestet in Office 16 - mit VBAHTML 12.6.0
Mit 'updateImage' wird das Bild geladen, mit 'deleteImage' wieder gelöscht.