VBA-Beispiel 145
mail schreiben
mail schreiben

Klassenprogrammierung - Labels zur Laufzeit erstellen

In einer UserForm soll zur Laufzeit für jeden Namen aus Spalte A ein Label erzeugt werden. Beim MouseMove-Ereignis wird in der Tabelle die passende Zeile markiert und beim Click-Ereignis kommt eine kurze MessageBox. Bild der UserForm

'-----------------------------------------------------
'für die UserForm:
'-----------------------------------------------------

Private myColl As New Collection   
Private rngOld As Range   

Private Sub UserForm_Initialize()    
  Set rngOld = Selection 
  
  With frmDemo 
    .Height = 400
        
    With .fraControls 
      .Height = frmDemo.Height - 50
      .ScrollBars = fmScrollBarsVertical
      .BackColor = RGB(255, 255, 255)
      .BorderColor = RGB(127, 157, 185)
      .BorderStyle = fmBorderStyleSingle 
    End With  
    
    With .cmbCancel 
      .Top = frmDemo.Height - .Height - 30 
      .Left = frmDemo.Width - .Width - 30
    End With  
  End With  
  
  Call CreateControls(False)  

End Sub  

Private Sub chbLeereIgnorieren_Click()  
  Call CreateControls(Me.chbLeereIgnorieren.Value) 
End Sub  

Private Sub CreateControls(ByVal bolIgnore As Boolean)     
Dim lngLZ As Long, lngZe As Long   
Dim lngTop As Long    
Dim myClass As clsLabel  

'erstellt für jede Zelle in Sp A ein Label
  
  frmDemo.fraControls.Controls.Clear
  
  For lngZe = 1 To myColl.Count  
    myColl.Remove 1
  Next lngZe 
  
  lngLZ = Cells(Rows.Count, 1).End(xlUp).Row 
  lngTop = 0 

  For lngZe = 2 To lngLZ  
    Set myClass = New clsLabel  
    Set myClass.myLBL = frmDemo.fraControls.Controls.Add _
                    ("Forms.Label.1", "lblTest" & lngZe,True)   

    With myClass.myLBL 
      .Top = lngTop 
      .Height = 15
      .Width = frmDemo.fraControls.InsideWidth - 1 
      .Caption = "   " & Cells(lngZe, 1)
      .Tag = lngZe
      .WordWrap = False 
    End With  

    If bolIgnore = True And Cells(lngZe, 1) = "" Then    
      'nix
    Else 
      myColl.Add myClass
      lngTop = lngTop + myClass.myLBL.Height + 1 
    End If  
  Next lngZe 

  'Scrollbalken einstellen:
  frmDemo.fraControls.ScrollHeight = _
                    myColl.Count * (myClass.myLBL.Height + 1)
  Set myClass = Nothing   
  Me.Caption = "-> " & myColl.Count & " Einträge"
End Sub  

Private Sub cmbCancel_Click()  
  rngOld.Select
  Unload Me
End Sub  


'-----------------------------------------------------
'ins Klassenmodul:
'-----------------------------------------------------

Public WithEvents myLBL As MSForms.Label    

Private Sub myLBL_Click()  

  On Error GoTo Hell    
    'Rows(myLBL.Tag).Select
    MsgBox Cells(myLBL.Tag, 1) & vbLf & _
           Cells(myLBL.Tag, 2), , ""
  Exit Sub  
  
Hell:
    MsgBox "Sub: myLBL_Click" & vbLf & vbLf & _ 
           Err.Number & vbLf & _
           Err.Description, vbCritical, "Fehler!"
End Sub  

Private Sub myLBL_MouseMove(ByVal Button As Integer, _      
                            ByVal Shift As Integer, _    
                            ByVal x As Single, _   
                            ByVal y As Single)   
  On Error GoTo Hell    
    Call Hover(frmDemo.fraControls, myLBL) 
  Exit Sub  
  
Hell:
    MsgBox "Sub: myLBL_MouseMove" & vbLf & vbLf & _ 
           Err.Number & vbLf & _
           Err.Description, vbCritical, "Fehler!"
End Sub  


Private Sub Hover(ByVal fra As MSForms.Frame, _
                Optional lblHover As MSForms.Label)      
Dim con As Control  
'------------------------------------------------------------------------
'Sorgt für den Hover-Effekt aller Labels in dem jeweils angegebenen Frame
'Parameter:
'     fra         ist das Frame dessen Labels formatiert werden sollen.
'     lblHover    ist das Label unter der Maus.
'------------------------------------------------------------------------
  On Error GoTo Hell    
    'Alle Controls eines Frames durchlaufen
    For Each con In fra.Controls   
      If TypeName(con) = "Label" Then  
        With con 
            'erstmal jedes Label transparent
            .BorderStyle = 0  '0 = transparent, 1 = undurchsichtig
            .BackStyle = 0
  
            'Wenn ein Label mit Maus berührt wird (Optional)
            If Not lblHover Is Nothing Then     
              'Farbe für Hover-Label
              If con.Name = lblHover.Name Then  
                .BackColor = RGB(255, 231, 162)
                .BorderColor = RGB(255, 189, 105)
                .BorderStyle = 1  '0 = transparent, 1 = undurchsichtig
                .BackStyle = 1
                Rows(myLBL.Tag).Select
              End If  
            End If  
        End With    'con
      End If  
    Next con 
  Exit Sub  
  
Hell:
    MsgBox "Sub: Hover" & vbLf & vbLf & _ 
           Err.Number & vbLf & _
           Err.Description, vbCritical, "Fehler!"
End Sub  


Download:   vba145.zip