Bilder in Arbeitsmappen in einer Userform anzeigen

Beispieldatei (PicToClip.zip 99 kB)
Beispieldatei (PicInvert.zip 97 kB)

Mit diesem Beispiel ist es möglich, Bilder, die in beliebigen Arbeitsmappen als Shapes stecken, auf einer Zeichenfläche in einer Userform darzustellen. Als Nebeneffekt können auch beliebige Bilder, die sich als Bitmap in der Zwischenablage tummeln, angezeigt werden.

Die Mappe PicInvert macht im Prinzip das gleiche. Es wird das erste Bild des aktiven Blattes invertiert dargestellt. Es fehlt lediglich die Dateiauswahl und die Konstante SRCCOPY ist durch SRCINVERT ersetzt worden.

Die Userform enthält ein Rahmensteuerelement mit dem Namen "frmZiel", in welches das Bild gezeichnet wird. Ich benutze dafür ein Rahmensteuerelement, weil es ein eigenes Fenster darstellt, also auch einen eigenen Devicekontext besitzt. Auf die Userform gehören noch zwei Commandbuttons mit den Namen "cmdNeueDatei" und "cmdRefresh".

Die Datei, die das Bild enthält, muss kurz geöffnet werden, damit das Bild ins Clipboard gebracht werden kann. Das wird durch einen Klick auf den Button "cmdNeueDatei" angestoßen, wobei sich ein Dialog zur Dateiauswahl öffnet. Beim Öffnen der ausgewählten Mappe wird die Bidschirmaktualisierung von Excel ausgeschaltet, man bekommt von dieser Aktion also nur ein kurzes Flackern mit.
In diesem Bleistift wird jeweils das erste Bild auf Blatt 1 gesucht. Wird keine Datei ausgewählt, hält das Programm nach Bildern in der aktuellen Mappe auf Blatt 1 Ausschau.

Ein Klick auf den Button "cmdRefresh" malt das aktuelle Bild, welches sich in der Zwischenablage als Bitmap befindet, in den Rahmen, die Herkunft ist dabei egal. Das ist manchmal ganz hilfreich, denn das gezeichnete Bild im Rahmen ist flüchtig, wird also nicht neu gezeichnet, wenn man beispielsweise mit einem anderen Fenster darüberfährt.

Hier der Code aus dem Klassenmodul der Userform:

Option Explicit
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type
Private Type BITMAP
    bmType As Long
    bmWidth As Long
    bmHeight As Long
    bmWidthBytes As Long
    udtBMPlanes As Integer
    bmBitsPixel As Integer
    bmBits As Long
End Type
Private Declare Function FindWindowA _
   Lib "user32" ( _
   ByVal lpClassName As String, _
   ByVal lpWindowName As String _
   ) As Long
Private Declare Function GetDC _
   Lib "user32" ( _
   ByVal hwnd As Long _
   ) As Long
Private Declare Function ReleaseDC _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   ByVal hdc As Long _
   ) As Long
Private Declare Function GetWindow _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   ByVal wCmd As Long _
   ) As Long
Private Declare Function GetObject _
   Lib "gdi32" Alias "GetObjectA" ( _
   ByVal hObject As Long, _
   ByVal nCount As Long, _
   lpObject As Any _
   ) As Long
Private Declare Function CloseClipboard _
   Lib "user32" () As Long
Private Declare Function OpenClipboard _
   Lib "user32" ( _
   ByVal hwnd As Long _
   ) As Long
Private Declare Function GetClipboardData _
   Lib "user32" ( _
    ByVal wFormat As Long _
    ) As Long
Private Declare Function IsClipboardFormatAvailable _
    Lib "user32" ( _
    ByVal wFormat As Long _
    ) As Long
Private Declare Function SelectObject _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal hObject As Long _
   ) As Long
Private Declare Function CreateCompatibleDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function DeleteDC _
   Lib "gdi32" ( _
   ByVal hdc As Long _
   ) As Long
Private Declare Function RedrawWindow _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   lprcUpdate As Any, _
   ByVal hrgnUpdate As Long, _
   ByVal fuRedraw As Long _
   ) As Long
Private Declare Function GetWindowRect _
   Lib "user32" ( _
   ByVal hwnd As Long, _
   lpRect As RECT _
   ) As Long
Private Declare Function StretchBlt _
   Lib "gdi32" ( _
   ByVal hdc As Long, _
   ByVal X As Long, _
   ByVal Y As Long, _
   ByVal nWidth As Long, _
   ByVal nHeight As Long, _
   ByVal hSrcDC As Long, _
   ByVal xSrc As Long, _
   ByVal ySrc As Long, _
   ByVal nSrcWidth As Long, _
   ByVal nSrcHeight As Long, _
   ByVal dwRop As Long _
   ) As Long
   
Private Const RDW_INVALIDATE = &H1
Private Const CF_BITMAP = 2
Private Const GW_CHILD = 5
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const SRCCOPY = &HCC0020

Private Sub cmdRefresh_Click()
   ClipboardToPicture
End Sub

Private Sub cmdNeueDatei_Click()
Dim strFile       As String
Dim objWorkbook   As Workbook

On Error Resume Next

   ' Dateipfad holen
   strFile = Application.GetOpenFilename( _
      "Excel-Dateien (*.xls), *.xls")
      
   ' Bildschirmaktualisierung ausschalten
   Application.ScreenUpdating = False
   
   ' Exceldatei öffnen
   Set objWorkbook = Workbooks.Open(strFile)
   
   ' Das erste Bild auf Blatt 1 des aktiven
   ' Workbooks ins Clipboard bringen
   If BringPictureToClip(Worksheets(1).Name) = "" Then
      MsgBox "Kein Bild auf Blatt 1"
   Else
      Me.Caption = ActiveWindow.Caption
      ' Bild aus dem Clipboard in das Rahmenfeld
      ClipboardToPicture
   End If
   
   ' Geöffnete Mappe schließen
   objWorkbook.Close
   
   ' Bildschirmaktualisierung einschalten
   Application.ScreenUpdating = True
End Sub

Private Sub ClipboardToPicture()
Dim lngBitmap        As Long
Dim lngMemoryBMP     As Long
Dim lngOldBitmap     As Long
Dim lngFrameHwnd     As Long
Dim lngFormDC        As Long
Dim lngMemDC         As Long
Dim udtBMP           As BITMAP
Dim dblBreite        As Double
Dim dblHöhe          As Double
Dim udtAbmessungen   As RECT
Dim dblHöheZuBreite  As Double

On Error GoTo fehlerbehandlung

' Handle auf das Rahmenfenster
lngFrameHwnd = GetFrameHwnd()

' Clipboard öffnen
OpenClipboard 0&

If IsClipboardFormatAvailable(CF_BITMAP) Then
   'Im Clipboard ist eine Bitmap
   
   'Einen zum Screen kompatiblen Devicekontext erzeugen
   lngMemDC = CreateCompatibleDC(0)
   
   If lngMemDC Then
    
      'Zugriffsnummer auf Bitmap im Clip holen
      lngBitmap = GetClipboardData(CF_BITMAP)
      
      If (lngBitmap) Then
         ' Im Clipboard ist eine Bitmap
         
            'Die Struktur udtBMP mit Infos füllen
            GetObject lngBitmap, Len(udtBMP), udtBMP
            
            'Die Bitmap in den erzeugten DC stellen
            lngOldBitmap = SelectObject(lngMemDC, lngBitmap)
            
            If lngOldBitmap Then
            
                ' Verhältnis Höhe zu Breite ermitteln
                With udtBMP
                  dblHöheZuBreite = .bmHeight / .bmWidth
                End With
                
                ' Rahmengröße anpassen
                With frmZiel
                
                  .Height = Me.Height - 20
                  .Width = .Height / dblHöheZuBreite
                  
                  If .Width > (Me.Width - (Me.Width / 3)) Then
                     .Width = .Width / 2
                     .Height = Height / 2
                  End If
                  
                End With
                
               'Abmessungen holen
               GetWindowRect lngFrameHwnd, udtAbmessungen

               'Alten Kram im Rahmen löschen
               RedrawWindow lngFrameHwnd, ByVal 0&, _
                   ByVal 0&, RDW_INVALIDATE
                   
               'Zeit lassen
               DoEvents
               
               'DC Frame ausleihen
               lngFormDC = GetDC(lngFrameHwnd)
               
               'Bild Maximiert einfügen
               With udtAbmessungen
                  StretchBlt lngFormDC, 0, 0, _
                     .Right - .Left, _
                     .Bottom - .Top, _
                     lngMemDC, 0, 0, _
                     udtBMP.bmWidth, _
                     udtBMP.bmHeight, _
                     SRCCOPY
               End With
               
               ' Alte Bitmap zurück in den MemDC
               SelectObject lngMemDC, lngOldBitmap
               
               'Frame DC zurückgeben
               ReleaseDC lngFrameHwnd, lngFormDC
               
            End If
        End If
        
        'Erzeugten DC löschen
        DeleteDC lngMemDC
        
    End If
    
End If

' Clipboard schließen
CloseClipboard

Exit Sub
fehlerbehandlung:

'Clipboard schließen
CloseClipboard

If lngOldBitmap <> 0 Then
    SelectObject lngMemDC, lngOldBitmap
    'Frame DC zurückgeben
    ReleaseDC lngFrameHwnd, lngFormDC
    'Erzeugten DC löschen
    DeleteDC lngMemDC
End If
End Sub

Private Function BringPictureToClip( _
   strSheetname As String, _
   Optional lngPicNr As Long = 1 _
   ) As String
Dim i As Long
Dim k As Long
On Error GoTo fehlerbehandlung

With Worksheets(strSheetname)
   For i = 1 To .Shapes.Count
      ' Alle Shapes des Blattes durchsuchen
      
      If .Shapes(i).Type = msoPicture Then
         ' Bild gefunden
         
         k = k + 1
         If k = lngPicNr Then
            ' Handelt es sich um die gesuchte Bildnummer
            
            ' ins Clipboard kopieren
            .Shapes(i).CopyPicture _
               Appearance:=xlScreen, Format:=xlBitmap
               
            ' Namen des kopierten Bildes zurückgeben
            BringPictureToClip = .Shapes(i).Name
            
         End If
      End If
   Next
End With
fehlerbehandlung:
End Function

Private Function GetFrameHwnd() As Long
Dim strCaption As String
Dim strGUID    As String
Dim lngHandle  As Long

    'Hier wird das Fenster mittels einer
    'eindeutigen Caption gesucht
    strGUID = "Disch griige mer aach"
    
    'Fenstertext zwischenspeichern
    strCaption = Me.Caption
    
    'Fenstertext kurz ändern
    Me.Caption = strGUID
    
    'Zugriffsnummer Form
    lngHandle = FindWindowA(vbNullString, strGUID)
    

    'Zugriffsnummer Clientbereich Form
    lngHandle = GetWindow(lngHandle, GW_CHILD)
    
    'Zugriffsnummer Frame
    lngHandle = GetWindow(lngHandle, GW_CHILD)
    
    'Fenstertext zurücksetzen
    Me.Caption = strCaption
    
    'Handle zurückgeben
    GetFrameHwnd = lngHandle
End Function