Lupe - Label - Klassenprogrammierung!

Mal wieder nachgefragt: Wie kann man eine Art Lupe programmieren, die bei Wechsel der Zelle den Inhalt vergrößert darstellt? Beim verlassen der Zelle wieder Urzustand. Das Ganze jederzeit Ein- bzw. Ausschaltbar. Habe mal einen alten Code ausgegraben:

Lupe - Label - Klassenprogrammierung...[ZIP, 60 KB]

Code in "DieseArbeitsmappe":

Option Explicit
Private Sub Workbook_Open()
Application.OnKey "{F3}", "Application_Ereignis.An"
Application.OnKey "{F4}", "Application_Ereignis.Aus"
Call An
End Sub
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Application.OnKey "{F3}"
Application.OnKey "{F4}"
Call Aus
End Sub



Code in ein Modul mit Namen "Application_Ereignis":

Option Explicit
Dim AppObject As New clsDatei
Public Sub An()
Set AppObject.AppLiCa = Application
End Sub
Public Sub Aus()
Dim objOLEObject As OLEObject
If Workbooks.Count < 1 Then Exit Sub
For Each objOLEObject In ActiveSheet.OLEObjects
If TypeOf objOLEObject.Object Is MSForms.Label Then
If objOLEObject.Name = "Lupe" Then objOLEObject.Delete
Exit For
End If
Next
Dim oS As Shape
Set AppObject.AppLiCa = Nothing
End Sub



Code in ein Klassenmodul mit Namen "clsDatei":

Option Explicit
Public WithEvents AppLiCa As Application
Private Sub AppLiCa_SheetSelectionChange(ByVal Sh As Object, _
ByVal Target As Range)
Dim objOLEObject As OLEObject
Dim intBerechnen As Integer
Dim objLabel As Object
If Target.Count > 2 Then Exit Sub
With Application
intBerechnen = .Calculation
.Calculation = -4135
End With
If Target.Value <> "" Then
For Each objOLEObject In Sh.OLEObjects
If TypeOf objOLEObject.Object Is MSForms.Label Then
If objOLEObject.Name = "Lupe" Then objOLEObject.Delete
Exit For
End If
Next
Set objLabel = Sh.OLEObjects.Add(ClassType:="Forms.Label.1", _
Left:=Target.Left, Top:=Target.Top, _
Width:=Target.Width * 2, Height:=Target.Height * 2)
objLabel.Name = "Lupe"
With objLabel.Object
.Caption = Target.Value
.Font.Size = 20
.TextAlign = 2
.ForeColor = Target.Font.Color
.BackColor = Target.Interior.Color
End With
Else
For Each objOLEObject In Sh.OLEObjects
If TypeOf objOLEObject.Object Is MSForms.Label Then
If objOLEObject.Name = "Lupe" Then objOLEObject.Delete
Exit For
End If
Next
End If
Set objLabel = Nothing
Application.Calculation = intBerechnen
End Sub

Kommentare

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...