Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1704to1708
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Bilder aus Tabelle in Image Frame einfügen

Bilder aus Tabelle in Image Frame einfügen
08.08.2019 00:58:56
karstenbrandt1@gmx.de
Hallo Gemeinde,
nach einer gut zwei stündigen suche im Internet wende ich mich nun an euch:
Ich habe eine Excel-Sheet, auf dem sich in Zellen Bilder befinden (per copy & paste eingefügt). Wichtig ist, dass die Bilder in Zellen sind. Es gibt eine Art Datenstruktur (Frageliste für ein Test, der dann in einem User-Form läuft), bei der die Bilder sich in einer bestimmten Spalte sich befinden. Die einzelnen Fragen sind fortlaufen untereinander angeordnet. Die Frageninhalte mit Antworten und ggf. auch Bildern sind in Spalten angeordnet.
Da es nicht zu jeder Frage ein Bild gibt, möchte ich prüfen, ob ein Bild in der "Bild"-Zelle in Spalte D vorliegt und bei Vorhandensein im User-Form im Image-Frame (oder alternativ einer Schaltfläche darstellen.
Die Frage ist nun,
a) wie prüfe ich, ob eine bestimmte Zelle ein Bild enthält
b) wie das enthaltene Bild aus der Zelle ausgelesen wird
c) das ausgelesene Bild einem Image-Frame oder auf einem Button angezeigt wird.
Vielen Dank und Gruß

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Bilder aus Tabelle in Image Frame einfügen
08.08.2019 08:31:03
Nepumuk
Hallo Karsten,
hier ein Beispiel. Gesucht wird ein Bild dessen obere linke Ecke in Zelle D5 liegt. Wird es gefunden, so wird es in einem image-Control auf Userform1 angezeigt.
Option Explicit

Public Sub Test()
    Dim objShape As Shape
    Set objShape = SearchPicture("$D$5")
    If Not objShape Is Nothing Then
        Call ShowPicture(objShape)
    Else
        Call MsgBox("Nix gefunden")
    End If
End Sub

Private Function SearchPicture(ByVal pvstrAddress As String) As Shape
    Dim objShape As Shape
    For Each objShape In Tabelle1.Shapes
        If objShape.Type = msoPicture Then
            If objShape.TopLeftCell.Address = pvstrAddress Then
                Set SearchPicture = objShape
                Set objShape = Nothing
                Exit For
            End If
        End If
    Next
End Function

Option Explicit
Option Private Module

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 Sub ShowPicture(ByRef probjShape As Shape)
    
    Dim lngptrCopy As LongPtr
    
    Call OpenClipboard(0&)
    Call EmptyClipboard
    Call CloseClipboard
    
    Call probjShape.CopyPicture(Appearance:=xlScreen, Format:=xlBitmap)
    
    With UserForm1
        
        Set .Image1.Picture = PastePicture(lngptrCopy)
        Call .Show
        
    End With
    
    Call DeleteObject(lngptrCopy)
    
End Sub

Gruß
Nepumuk
Anzeige

333 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige