Icon in UserForm

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

AW: Icon in UserForm

19.11.2017 16:57:10

Sepp

AW: Icon in UserForm

19.11.2017 16:58:17

Hajo_Zi

AW: Icon in UserForm

19.11.2017 17:10:40

Christian

AW: Icon in UserForm

19.11.2017 17:14:06

Sepp

AW: Icon in UserForm

19.11.2017 17:25:12

Christian

AW: Icon in UserForm

19.11.2017 17:33:35

Sepp

AW: Icon in UserForm

20.11.2017 07:20:45

Christian

Hallo Christian,
geht auch, allerdings nur per Copy & Paste.
Oder per Code.

'© 2015 by Nepumuk - http://www.herber.de/forum/messages/1458287.html
'Modul des UF

Private Sub Image1_Click()
Set Image1.Picture = ShowShape(Tabelle1, "Ellipse2")
Repaint
End Sub

'In einem Standardmodul:

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
  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}"

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 ShowShape( _
  ByRef probjWorksheet As Worksheet, _
  ByVal pvstrShapeName As String) As IPictureDisp

Static slngptrCopy As LongPtr

Call OpenClipboard(0&)
Call EmptyClipboard
Call CloseClipboard

If slngptrCopy <> 0 Then Call DeleteObject(slngptrCopy)

probjWorksheet.Shapes(pvstrShapeName).CopyPicture _
  Appearance:=xlScreen, Format:=xlBitmap

Set ShowShape = PastePicture(slngptrCopy)

If ShowShape Is Nothing Then _
  Call MsgBox("Shape can't show in Userform", vbCritical, "Error")

End Function

Gruß Sepp

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Icon in UserForm

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread