Ellipse aus Tab.blt. in Image 1 einfügen

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
UserForm MsgBox
Bild

Betrifft: Ellipse aus Tab.blt. in Image 1 einfügen
von: Dieter(Drummer)
Geschrieben am: 13.11.2015 14:54:37

Hi VBA Spezialisten,
mit folgenden Code möchte ich eine "Ellipse2" in Userform1.Image1, einfügen.
Der Code bricht aber bei "Ellipse2" ab. Was ist am Code falsch oder geht das garnicht?
Die "Ellipse2" existiert in Tab.blt1.
Gruß und Danke für evtl. Hilfe, Dieter(Drummer)

  • 
    Private Sub Image1_Click()
    UserForm1.Image1.Picture = Tabelle1.Ellipse2.Picture
    End Sub

  • Bild

    Betrifft: AW: Ellipse aus Tab.blt. in Image 1 einfügen
    von: Sepp
    Geschrieben am: 13.11.2015 21:12:55
    Hallo Dieter,
    das kann so nicht funktionieren, ein Shape (Form) ist ein Zeichnungsobjekt und kein Bild!
    Das Image-Steuerelement erwartet aber eine Bilddatei als Quelle.
    Das geht z. B. so:

    ' **********************************************************************
    ' Modul: Modul1 Typ: Allgemeines Modul
    ' **********************************************************************

    Option Explicit

    '© 2015 by Nepumuk - http://www.herber.de/forum/messages/1449628.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
    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 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
      .Size = Len(udtPicInfo)
      .Type = 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 ExportPicture(objShape As Object, strFileName As String) As Long

    Dim lngptrCopy As LongPtr
    Dim objPicture As IPictureDisp

    Call OpenClipboard(0&)
    Call EmptyClipboard
    Call CloseClipboard

    objShape.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

    Set objPicture = PastePicture(lngptrCopy)

    If Not objPicture Is Nothing Then
      Call SavePicture(Picture:=objPicture, Filename:=strFileName)
      ExportPicture = -1
    End If

    Call DeleteObject(lngptrCopy)

    End Function

    ' **********************************************************************
    ' Modul: UserForm1 Typ: Userform
    ' **********************************************************************

    Option Explicit

    Private Sub Image1_Click()
    Dim objShp As Shape
    Dim strTmp As String

    strTmp = Environ("TEMP") & "\tmp.jpg"

    Set objShp = Sheets("Tabelle1").Shapes("Ellipse2")

    If ExportPicture(objShp, strTmp) Then
      Image1.Picture = LoadPicture(strTmp)
      Me.Repaint
    End If

    Set objShp = Nothing
    End Sub

    Gruß Sepp


    Bild

    Betrifft: AW: Ellipse aus Tab.blt. in Image 1 einfügen
    von: Nepumuk
    Geschrieben am: 14.11.2015 11:20:15
    Hallo,
    das geht auch ohne den Umweg über die Festplatte:

    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ß
    Nepumuk

     Bild

    Beiträge aus den Excel-Beispielen zum Thema "Ellipse aus Tab.blt. in Image 1 einfügen"