Icon in UserForm

Christian · 2017-11-19T16:55:38+00:00

Hallo Zusammen, ich habe mir aus einer Grafik in die Tabelle 1 ein "Icon" gelegt, dass ein Marko auslöst. Eigentlich würde ich das aber gerne in eine UserForm einfügen. Geht das nur, wenn ich das Icon zuvor lokal speicher? Und wenn ja, funktioniert es dann auch, wenn ich die Datei versende und an anderer Stelle öffne? Vielen Dank und viele Grüße 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

Forumthread: Icon in UserForm

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial

Icons in UserForm einfügen

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)