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 Long) As 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 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 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 a 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 i 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 3 'Spalte
Spaltenbreite(i) = .Cells(y(1), x(1) + i - 1).Width
Breite = Breite + Spaltenbreite(i)
Next
For i = 1 To 5 '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