Option Explicit
Private Declare PtrSafe Function OleCreatePictureIndirect
Lib "oleaut32.dll" (
_
ByRef PicDesc
As PIC_DESC,
ByRef RefIID
As GUID, _
ByVal fPictureOwnsHandle
As LongPtr,
ByRef IPic
As IPictureDisp)
As Long
Private Declare PtrSafe Function CopyImage
Lib "user32" (
_
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" (
_
ByVal wFormat
As Long)
As Long
Private Declare PtrSafe Function GetClipboardData
Lib "user32" (
_
ByVal wFormat
As Long)
As LongPtr
Private Declare PtrSafe Function OpenClipboard
Lib "user32" (
ByVal hwnd
As LongPtr)
As Long
Private Declare PtrSafe Function CloseClipboard
Lib "user32" (
)
As Long
Private Type PIC_DESC
lSize
As Long
lType
As Long
hPic
As LongPtr
hPal
As LongPtr
End Type
Private Type GUID
Data1
As Long
Data2
As Integer
Data3
As Integer
Data4(
0 To 7)
As Byte
End Type
Private Const PICTYPE_BITMAP =
1
Private Const CF_BITMAP =
2
Private Const IMAGE_BITMAP =
0
Private Const LR_COPYRETURNORG =
&H4
Sub Test()
CopyPictureFromPosition
1
Paste_Picture_inUF
End Sub
Function CopyPictureFromPosition(iZeile As Long) As Boolean
'Ermittelt das Bild, dass an der angegebenen Zeile zu finden ist
'und kopiert es in die Zwischenablage
Dim oShape
As Shape
With ThisWorkbook.Sheets(
"Sternzeichen")
For Each oShape In .Shapes
If oShape.TopLeftCell.Address = .Cells(iZeile,
"C").Address
Then
oShape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
CopyPictureFromPosition =
True
DoEvents
Exit For
End If
Next oShape
End With
End Function
Sub Paste_Picture_inUF()
'Holt ein Bild aus der Zwischenablage und fügt in die Userform ein
Dim oPict
As IPictureDisp
Dim hPic
As LongPtr, hCopy
As LongPtr
If IsClipboardFormatAvailable(CF_BITMAP) <>
0 Then
If OpenClipboard(
0&) <>
0 Then
hPic = GetClipboardData(CF_BITMAP)
hCopy = CopyImage(hPic, IMAGE_BITMAP,
0,
0, LR_COPYRETURNORG)
CloseClipboard
If hPic <>
0 Then Set oPict = Create_Picture(hCopy)
If Not oPict
Is Nothing Then
UserForm1.Image1.Picture = oPict
'Bild in Userform einfügen
Else
MsgBox "Ds Bild kann nicht angezeigt werden",
vbCritical,
"Bild einfügen"
End If
End If
End If
UserForm1.Show
End Sub
Private Function Create_Picture( _
ByVal hPic
As LongPtr)
As IPictureDisp
Dim tPicInfo
As PIC_DESC, tID_IDispatch
As GUID
Dim oPict
As IPictureDisp
With tID_IDispatch
.Data1 =
&H20400
.Data4(
0) =
&HC0
.Data4(
7) =
&H46
End With
With tPicInfo
.lSize = Len(tPicInfo)
.lType = PICTYPE_BITMAP
.hPic = hPic
.hPal =
0
End With
OleCreatePictureIndirect tPicInfo, tID_IDispatch,
0&, oPict
Set Create_Picture = oPict
End Function 