Zurück zur Homepage

Excellupe.

Die aktive Zelle und der umliegende Bereich werden in einer User-Form als Bitmap vergrößert dargestellt. Die User-Form enthält ein Rahmensteuerelement. Das ist so ziemlich das einzige Steuerelement in Office, welches ein echtes Fenster besitzt. Ein Fenster ist wichtig, da man einen DC braucht, in dem man das Bitmap malen kann. Man könnte zwar auch direkt in die Form zeichnen, ist aber etwas mehr Rechnerei, da ja noch andere Steuerelemente auf der Form sind. Die anderen Steuerelemente auf der Form sind Commandbuttons. Für drei Spalten und fünf Zeilen je eins, um die Zeilen- und Spaltenköpfe darzustellen.
Der Code ist eine wahre Orgie an API-Aufrufen, deshalb bitte nicht erschrecken. Ob das so in der Praxis einsetzbar ist, kann ich nicht beurteilen. Mittlerweile ist die Mappe unter den verschiedesten Versionen erfolgreich getestet worden, trotzdem können Fehler auftreten. Deshalb eine Mail an mich, wenn es auch unter anderen Versionen eingesetzt wird und dort nicht funktioniert. Probleme treten meistens durch unterschiedliche Klassennamen der Fenster auf. Und noch ein kleiner Schönheitsfehler: Unter XL97 gibt es keine Modeless Formen. Man kann das zwar mit einer API-Funktion machen und kann danach wie gewohnt mit dem Tabellenblatt arbeiten. Ein Problem gibt es. Um mit den Menüs zu arbeiten, muss einmal ein Doppelklick auf irgendein Menü oder Commandbutton gemacht werden. Dann geht der Dialog Anpassen auf. Sobald der weggeklickt wird, ist alles in Ordnung.

Beispielmappe (Excellupe.zip 41 KB)

 

'**************************************************
'Das Folgende zeigt die Verwendung der Form.
************************************************** 
 

Option Explicit


Private iVerfolgung As Boolean


Private Sub cmbVerfolgung_Click()
On Error Resume Next
If iVerfolgung Then
    cmbVerfolgung.Caption = 
"Verfolgung Ein"
Else
    cmbVerfolgung.Caption = 
"Verfolgung Aus"
End If
iVerfolgung = 
Not iVerfolgung
If iVerfolgung Then
   ufVerfolgung.Aktualisieren
Else
   ufVerfolgung.Hide
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If iVerfolgung Then ufVerfolgung.Aktualisieren
End Sub

'**************************************************
'Das Folgende zeigt die Form.
************************************************** 

Option Explicit
Private Type BITMAP
    bmType 
As Long
    bmWidth 
As Long
    bmHeight 
As Long
    bmWidthBytes 
As Long
    bmPlanes 
As Integer
    bmBitsPixel 
As Integer
    bmBits 
As Long
End Type
Private Declare Function FindWindowEx Lib "user32" _
    
Alias "FindWindowExA" ( _
    
ByVal hWnd1 As Long, _
    
ByVal hWnd2 As Long, _
    
ByVal lpsz1 As String, _
    
ByVal lpsz2 As String _
    ) 
As Long
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 LongAs Long
Private Declare Function EmptyClipboard Lib _
    
"user32" () As Long
Private Declare Function SetClipboardData Lib _
    
"user32" ( _
    
ByVal wFormat As Long, _
    
ByVal hMem _
    
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 CopyImage Lib "user32" ( _
    
ByVal handle As Long, _
    
ByVal un1 As Long, _
    
ByVal n1 As Long, _
    
ByVal n2 As Long, _
    
ByVal un2 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 EnableWindow Lib "user32" ( _
    
ByVal hwnd As Long, _
    
ByVal bEnable 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 SetFocus Lib "user32" ( _
    
ByVal hwnd As Long _
    ) 
As Long
Private Declare Function StretchBlt Lib "gdi32" ( _
    
ByVal hdc As Long, _
    
ByVal As Long, _
    
ByVal 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 LongAs Long
Private Const RDW_INVALIDATE = &H1
Private Const GMEM_ZEROINIT = &H40
Private Const GMEM_MOVEABLE = &H2
Private Const GMEM_SHARE = &H2000
Private Const GMEM_All = ( _
    GMEM_ZEROINIT 
Or _
    GMEM_SHARE 
Or _
    GMEM_MOVEABLE)
Private Const CF_TEXT = 1
Private Const CF_BITMAP = 2
Private Const IMAGE_BITMAP = 0
Private Const LR_COPYRETURNORG = &H4
Private Const GW_CHILD = 5
Private Const GW_HWNDFIRST = 0
Private Const GW_HWNDNEXT = 2
Private Const SRCCOPY = &HCC0020
Private myHwnd As Long, myDeskHwnd As Long
Private Spaltenbreite(1 To 3) As Long
Private Zeilenhöhe(1 To 5) As Long
Private FXY As Double


Public Sub Aktualisieren()
#
If VBA6 = 0 Then
    
If Me.Visible = False Then Me.Show
#
Else
    
If Me.Visible = False Then Me.Show 0
#
End If
If chbAktivieren = True Then
   UserForm_Activate
End If
End Sub


Private Sub chbAktivieren_Click()
    
If chbAktivieren = True Then Formatieren
End Sub


Private Sub UserForm_Activate()
Dim As Long
#
If VBA6 = 0 Then
    
'Zugriffsnummer Excel ermitteln
    a = FindWindowA(
"XLMAIN", Application.Caption)
    
If a = 0 Then a = FindWindowA(vbNullString, Application.Caption)
    
'Form Modeless machen (Nur XL 97)
    
'Danach kann man wie gewohnt mit dem Tabellenblatt
    
'arbeiten. Ein Problem gibt es: Um mit den Menüs zu
    
'arbeiten, muss einmal ein Doppelklick auf irgendein
    
'Menü oder Commandbutton gemacht werden. Dann geht
    
'der Dialog Anpassen auf. Wenn der weggeklickt wird,
    
'ist alles in Ordnung.
    EnableWindow a, 1
    SetFocus a
    
'Den Bereich um die aktive Zelle sichtbar machen
#
Else
    Me.Show 0
#
End If
    Formatieren
End Sub


Private Sub ClipboardToPicture()
Dim hBitmap As Long, lngMemoryBMP As Long
Dim hOldBitmap As Long, FormDC As Long
Dim dummyDC As Long, BMP As BITMAP
Dim Breite As Double, Höhe As Double
Dim txtReturn As String
On Error GoTo fehlerbehandlung
If myHwnd = 0 Then myHwnd = GetFrameHwnd()
OpenClipboard 0&
If IsClipboardFormatAvailable(CF_BITMAP) Then
    
'Im Clipboard ist eine Bitmap
    
'Einen zum Screen kompatiblen Devicekontext erzeugen
    dummyDC = CreateCompatibleDC(0)
    
If dummyDC Then
        
'Zugriffsnummer auf Bitmap im Clip holen
        hBitmap = GetClipboardData(CF_BITMAP)
        
If (hBitmap) Then
            
'Die Struktur BMP mit Infos füllen
            GetObject hBitmap, Len(BMP), BMP
            
'Die Bitmap in den erzeugten DC stellen
            hOldBitmap = SelectObject(dummyDC, hBitmap)
            
If (hOldBitmap) Then
                
'Alten Kram im Rahmen löschen
                RedrawWindow myHwnd, 
ByVal 0&, _
                    
ByVal 0&, RDW_INVALIDATE
                
'Zeit lassen
                DoEvents
                
'DC Frame ausleihen
                FormDC = GetDC(myHwnd)
                
'Bild Maximiert einfügen
                StretchBlt FormDC, 0, 0, _
                    
CLng(BMP.bmWidth * FXY), _
                    
CLng(BMP.bmHeight * FXY), _
                    dummyDC, 0, 0, _
                    BMP.bmWidth, _
                    BMP.bmHeight, _
                    SRCCOPY
                SelectObject dummyDC, hOldBitmap
                
'Frame DC zurückgeben
                ReleaseDC myHwnd, FormDC
            
End If
        
End If
        
'Erzeugten DC löschen
        DeleteDC dummyDC
    
End If
End If
'Clipboard schließen
CloseClipboard
Exit Sub
fehlerbehandlung:
'Clipboard schließen
CloseClipboard
If hOldBitmap <> 0 Then
    SelectObject dummyDC, hOldBitmap
    
'Frame DC zurückgeben
    ReleaseDC myHwnd, FormDC
    
'Erzeugten DC löschen
    DeleteDC dummyDC
End If
End Sub


Private Sub Formatieren()
Dim x(1 To 2) As Long, y(1 To 2) As Long
Dim Breite As Double, Höhe As Double
Dim AktiveSpalte As Long, AktiveZeile As Long
Dim As Long, k As String
If chbAktivieren = False Then Exit Sub
AktiveSpalte = ActiveCell.Column
AktiveZeile = ActiveCell.Row
'Den zu kopierenden Bereich berechnen.
'Fünf Zeilen hoch und drei Spalten breit
y(1) = AktiveZeile: x(1) = AktiveSpalte
If y(1) - 2 < 1 Then y(1) = 1 Else y(1) = y(1) - 2
If y(1) + 4 > 65535 Then
    y(2) = 65535: y(1) = 65531
Else
    y(2) = y(1) + 4
End If
If x(1) - 1 < 1 Then x(1) = 1 Else x(1) = x(1) - 1
If x(1) + 2 > 255 Then
    x(2) = 255: x(1) = 253
Else
    x(2) = x(1) + 2
End If
With ActiveSheet
    
'Max. Größe Zielbitmap berechnen
    
For i = 1 To 'Spalte
        Spaltenbreite(i) = .Cells(y(1), x(1) + i - 1).Width
        Breite = Breite + Spaltenbreite(i)
    
Next
    
For i = 1 To 'Zeile
        Zeilenhöhe(i) = .Cells(y(1) + i - 1, x(1)).Height
        Höhe = Höhe + Zeilenhöhe(i)
    
Next
    FXY = frmZiel.Width / Breite
    
If FXY * Höhe > frmZiel.Height Then
        FXY = frmZiel.Height / Höhe
    
End If
    
'+++++++++++++++++++++++++++++++
    
'Die Spaltenköpfe anpassen
    
'Farbe Spalten
    cmbSpalte1.BackColor = &H8000000F
    cmbSpalte2.BackColor = &H8000000F
    cmbSpalte3.BackColor = &H8000000F
    
Select Case AktiveSpalte
        
Case x(1)
            cmbSpalte1.BackColor = &H80000010
        
Case x(1) + 1
            cmbSpalte2.BackColor = &H80000010
        
Case x(1) + 2
            cmbSpalte3.BackColor = &H80000010
    
End Select
    cmbSpalte1.Width = Spaltenbreite(1) * FXY
    
'Bezeichnung und Breite Spalte 1
    k = .Cells(1, x(1)).Address
    cmbSpalte1.Caption = Mid(k, 2, InStr(2, k, 
"$") - 2)
    cmbSpalte2.Left = cmbSpalte1.Left + cmbSpalte1.Width
    k = .Cells(1, x(1) + 1).Address
    cmbSpalte2.Caption = Mid(k, 2, InStr(2, k, 
"$") - 2)
    cmbSpalte2.Width = Spaltenbreite(2) * FXY
    k = .Cells(1, x(1) + 2).Address
    cmbSpalte3.Caption = Mid(k, 2, InStr(2, k, 
"$") - 2)
    cmbSpalte3.Left = cmbSpalte2.Left + cmbSpalte2.Width
    cmbSpalte3.Width = Spaltenbreite(3) * FXY
    
'+++++++++++++++++++++++++++++++
    
'Die Zeilenköpfe anpassen
    
'Farbe Zeilenköpfe
    cmbZeile1.BackColor = &H8000000F
    cmbZeile2.BackColor = &H8000000F
    cmbZeile3.BackColor = &H8000000F
    cmbZeile4.BackColor = &H8000000F
    cmbZeile5.BackColor = &H8000000F
    
Select Case AktiveZeile
        
Case y(1)
            cmbZeile1.BackColor = &H80000010
        
Case y(1) + 1
            cmbZeile2.BackColor = &H80000010
        
Case y(1) + 2
            cmbZeile3.BackColor = &H80000010
        
Case y(1) + 3
            cmbZeile4.BackColor = &H80000010
        
Case y(1) + 4
            cmbZeile5.BackColor = &H80000010
    
End Select
    
'Bezeichnung und Höhe Zeilenköpfe
    cmbZeile1.Height = Zeilenhöhe(1) * FXY
    cmbZeile1.Caption = y(1)
    cmbZeile2.Top = cmbZeile1.Top + cmbZeile1.Height
    cmbZeile2.Height = Zeilenhöhe(2) * FXY
    cmbZeile2.Caption = y(1) + 1
    cmbZeile3.Top = cmbZeile2.Top + cmbZeile2.Height
    cmbZeile3.Height = Zeilenhöhe(3) * FXY
    cmbZeile3.Caption = y(1) + 2
    cmbZeile4.Top = cmbZeile3.Top + cmbZeile3.Height
    cmbZeile4.Height = Zeilenhöhe(4) * FXY
    cmbZeile4.Caption = y(1) + 3
    cmbZeile5.Top = cmbZeile4.Top + cmbZeile4.Height
    cmbZeile5.Height = Zeilenhöhe(5) * FXY
    cmbZeile5.Caption = y(1) + 4
    CloseClipboard
    
'Den Bereich als Bitmap in die Zwischenablage
    .Range(.Cells(y(1), x(1)), .Cells(y(2), x(2))).CopyPicture _
        Appearance:=xlScreen, Format:=xlBitmap
End With
ClipboardToPicture 
' Bild in User-Form
End Sub

Private Function GetFrameHwnd() As Long
Dim myCaption As String, myGuid As String
Dim iHandle As Long
    
'Wenn es geht, ohne Klassennamen arbeiten
    
'Hier wird das Fenster mittels einer
    
'eindeutigen Caption gesucht
    myGuid = 
"Disch griige mer aach"
    
'Fenstertext zwischenspeichern
    myCaption = Me.Caption
    
'Fenstertext kurz ändern
    Me.Caption = myGuid
    
'Zugriffsnummer Form
    iHandle = FindWindowA(vbNullString, myGuid)
    
'Zugriffsnummer Clientbereich Form
    iHandle = GetWindow(iHandle, GW_CHILD)
    
'Zugriffsnummer Frame
    iHandle = GetWindow(iHandle, GW_CHILD)
    
'Fenstertext zurück
    Me.Caption = myCaption
    GetFrameHwnd = iHandle
End Function

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    CloseClipboard
End Sub