ABOUT Visual Basic - das Webmagazin: Schaltfläche mit Dauerfeuer (ActiveX-Control)

ABOUT Visual Basic Programmieren Programmierung Download Downloads Tips & Tricks Tipps & Tricks Know-How Praxis VB VBA Visual Basic for Applications VBS VBScript Scripting Windows ActiveX COM OLE API ComputerPC Microsoft Office Microsoft Office 97 Office 2000 Access Word Winword Excel Outlook Addins ASP Active Server Pages COMAddIns ActiveX-Controls OCX UserControl UserDocument Komponenten DLL EXE

(-hg)

Eine Schaltfläche mit Dauerfeuer? Kein Problem - im MouseDown-Ereignis wird ein Timer eingeschaltet, im MouseUp-Ereignis wird er wieder abgeschaltet.

Na, ganz so schlicht sollte so eine wiederholt feuern könnende Schaltfläche nicht daherkommen. Daher packen wir zunächst einen CommandButton auf ein UserControl und reichen dessen wichtigste Eigenschaften und Methoden nach außen hin durch. Den vollständigen Code hierfür werden Sie am Ende dieses Artikels finden. Natürlich können Sie auch noch die letzten Details hinzufügen, die ich meinem persönlichen Geschmack entsprechend haben entfallen lassen.

Wichtig für die besondere Funktion unserer Repeater-Schaltfläche sind die hinzugekommenen Eigenschaften Interval und Repeat, sowie das Ereignis Repeat.

Die Eigenschaft Interval entspricht der dem ebenfalls auf dem UserControl platzierten Timer-Steuerelement. Sie wird direkt an den Timer durchgereicht.

Public Property Get Interval() As Long
  Interval = tmr.Interval
End Property

Public Property Let Interval(ByVal New_Interval As Long)
  On Error Resume Next
  tmr.Interval = New_Interval
  If Err.Number Then
    On Error GoTo 0
    Err.Raise 380
  Else
    PropertyChanged "Interval"
  End If
End Property

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  ' ...
  Me.Interval = PropBag.ReadProperty("Interval", 250)
  ' ...
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  ' ...
  PropBag.WriteProperty "Interval", tmr.Interval, 250
  ' ...
End Sub

Über die Eigenschaft Repeat schalten Sie die Dauerfeuer-Fähigkeit ein und aus. Ist sie ausgeschaltet, verhält sich die Schaltfläche wie ein gewöhnlicher CommandButton. Sollte zur Laufzeit Repeater auf False gesetzt werden, während der Timer aktiv ist, wird dieser auch gleich ausgeschaltet.

Private pRepeat As Boolean

Public Property Get Repeat() As Boolean
  Repeat = pRepeat
End Property

Public Property Let Repeat(ByVal New_Repeat As Boolean)
  pRepeat = New_Repeat
  If Not pRepeat Then
    tmr.Enabled = False
  End If
  PropertyChanged "Repeat"
End Property

Private Sub UserControl_Initialize()
  pRepeat = True
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  ' ...
  pRepeat = PropBag.ReadProperty("Repeat", True)
  ' ...
End Sub
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  ' ...
  PropBag.WriteProperty "Repeat", pRepeat, True
  ' ...
End Sub

Wie bereits Eingangs erwähnt wird der Repeater, genauer gesagt der Timer, im MouseDown-Ereignis eingeschaltet und im MouseUp-Ereignis wieder ausgeschaltet. Als kleine Verfeinerung wird mitgezählt, wie oft der Repeater seit dem Start ausgelöst wurde - hier in dem Mouse...-Ereignissen wird für die Rücksetzung des Zählers (mCount) gesorgt.

Private mCount As Long

Private Sub cmd_MouseDown(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)

  RaiseEvent MouseDown(Button, Shift, X, Y)
  mCount = 0
  tmr.Enabled = False
  If Button = vbLeftButton Then
    tmr.Enabled = pRepeat
    If pRepeat Then
      RaiseEvent Repeat(0)
    End If
  End If
End Sub

Private Sub cmd_MouseUp(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)

  tmr.Enabled = False
  mCount = 0
  RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Eine andere Verfeinerung enthält das MouseMove-Ereignis. So wie sich eine Schaltfläche wieder in den Ruhezustand begibt, wenn der Mauszeiger bei gedrückter (linker) Maustaste aus der Fläche heraus bewegt wird, wird auch der Timer unterbrochen. Bewegt sich der Mauszeiger wieder in die Schaltfläche hinein, wird er wieder reaktiviert.

Private Sub cmd_MouseMove(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)

  On Error Resume Next
  cmd.ToolTipText = Extender.ToolTipText
  On Error GoTo 0
  RaiseEvent MouseMove(Button, Shift, X, Y)
  If Button = vbLeftButton Then
    With cmd
      Select Case X
        Case 0 To .Width
          Select Case Y
            Case 0 To .Height
              With tmr
                If .Enabled = False Then
                  mCount = mCount + 1
                  .Enabled = True
                  RaiseEvent Repeat(mCount)
                End If
              End With
              Exit Sub
          End Select
      End Select
    End With
    tmr.Enabled = False
  End If
End Sub

Die eigentliche Arbeit des Feuerns hat der Timer zu leisten. In seinem Timer-Ereignis wird zunächst über die API-Funktion GetFocus geprüft, ob die Schaltfläche überhaupt noch den Fokus innehat. Hat sie ihn verloren, wird der Timer abgeschaltet. Hat sie noch den Fokus inne, wird der Wert des Zählers erhöht und es wird das spezielle Repeat-Ereignis ausgelöst.

Private Declare Function GetFocus Lib "user32" () As Long

Public Event Repeat(ByVal Count As Long)

<span class="codeproc">Private Sub tmr_Timer</span>()
  If GetFocus() <> cmd.hWnd Then
    tmr.Enabled = False
  Else
    mCount = mCount + 1
    RaiseEvent Repeat(mCount)
  End If
End Sub

Und das war es dann auch schon. Nun folgt noch, wie versprochen, der Code für das standardmäßige Durchreichen des CommandButtons nach außen hin (Der Vollständigkeit halber sind die oben stehenden Codeabschnitte noch einmal enthalten). Dessen Style-Eigenschaft ist übrigens auf "1 - grafisch" voreingestellt. Weisen Sie ihm keine Bilder zu, sieht er sowieso wie eine gewöhnliche Schaltfläche aus.

Private Declare Function GetFocus Lib "user32" () As Long

Private WithEvents eFont As StdFont

Private mCount As Long

Public Event Click()
Public Event KeyDown(KeyCode As Integer, Shift As Integer)
Public Event KeyPress(KeyAscii As Integer)
Public Event KeyUp(KeyCode As Integer, Shift As Integer)
Public Event MouseDown(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)
Public Event MouseMove(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)
Public Event MouseUp(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)
Public Event Repeat(ByVal Count As Long)

Private pRepeat As Boolean

Public Property Get Caption() As String
  Caption = cmd.Caption
End Property

Public Property Let Caption(New_Caption As String)
  cmd.Caption = New_Caption
  PropertyChanged "Caption"
End Property

Public Property Get DisabledPicture() As StdPicture
  Set DisabledPicture = cmd.DisabledPicture
End Property

Public Property Let DisabledPicture(New_DisabledPicture As StdPicture)
  zSetDisabledPicture New_DisabledPicture
End Property

Public Property Set DisabledPicture(New_DisabledPicture As StdPicture)
  zSetDisabledPicture New_DisabledPicture
End Property

Private Sub zSetDisabledPicture(New_DisabledPicture As StdPicture)
  Set cmd.DisabledPicture = New_DisabledPicture
  PropertyChanged "DisabledPicture"
End Sub

Public Property Get DownPicture() As StdPicture
  Set DownPicture = cmd.DownPicture
End Property

Public Property Let DownPicture(New_DownPicture As StdPicture)
  zSetDownPicture New_DownPicture
End Property

Public Property Set DownPicture(New_DownPicture As StdPicture)
  zSetDownPicture New_DownPicture
End Property

Private Sub zSetDownPicture(New_DownPicture As StdPicture)
  Set cmd.DownPicture = New_DownPicture
  PropertyChanged "DownPicture"
End Sub

Public Property Get Enabled() As Boolean
  Enabled = UserControl.Enabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  UserControl.Enabled = New_Enabled
  cmd.Enabled = New_Enabled
  If Not New_Enabled Then
    tmr.Enabled = False
  End If
  PropertyChanged "Enabled"
End Property

Public Property Get Font() As Font
  Set Font = cmd.Font
End Property

Public Property Let Font(New_Font As Font)
  zSetFont New_Font
End Property

Public Property Set Font(New_Font As Font)
  zSetFont New_Font
End Property

Private Sub zSetFont(New_Font As Font)
  Set cmd.Font = New_Font
  If Not Ambient.UserMode Then
    Set eFont = New_Font
  End If
  PropertyChanged "Font"
End Sub

Public Property Get Interval() As Long
  Interval = tmr.Interval
End Property

Public Property Let Interval(ByVal New_Interval As Long)
  On Error Resume Next
  tmr.Interval = New_Interval
  If Err.Number Then
    On Error GoTo 0
    Err.Raise 380
  Else
    PropertyChanged "Interval"
  End If
End Property

Public Property Get MaskColor() As OLE_COLOR
  MaskColor = cmd.MaskColor
End Property

Public Property Let MaskColor(ByVal New_MaskColor As OLE_COLOR)
  cmd.MaskColor = New_MaskColor
  PropertyChanged "MaskColor"
End Property

Public Property Get MouseIcon() As StdPicture
  Set MouseIcon = cmd.MouseIcon
End Property

Public Property Let MouseIcon(New_MouseIcon As StdPicture)
  zSetMouseIcon New_MouseIcon
End Property

Public Property Set MouseIcon(New_MouseIcon As StdPicture)
  zSetMouseIcon New_MouseIcon
End Property

Private Sub zSetMouseIcon(New_MouseIcon As StdPicture)
  Set cmd.MouseIcon = New_MouseIcon
  PropertyChanged "MouseIcon"
End Sub

Public Property Get MousePointer() As MousePointerConstants
  MousePointer = cmd.MousePointer
End Property

Public Property Let MousePointer _
 (ByVal New_MousePointer As MousePointerConstants)

  cmd.MousePointer = New_MousePointer
  PropertyChanged "MousePointer"
End Property

Public Property Get Picture() As StdPicture
  Set Picture = cmd.Picture
End Property

Public Property Let Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Public Property Set Picture(New_Picture As StdPicture)
  zSetPicture New_Picture
End Property

Private Sub zSetPicture(New_Picture As StdPicture)
  Set cmd.Picture = New_Picture
  PropertyChanged "Picture"
End Sub

Public Property Get Repeat() As Boolean
  Repeat = pRepeat
End Property

Public Property Let Repeat(ByVal New_Repeat As Boolean)
  pRepeat = New_Repeat
  If Not pRepeat Then
    tmr.Enabled = False
  End If
  PropertyChanged "Repeat"
End Property

Public Property Get UseMaskColor() As Boolean
  UseMaskColor = cmd.UseMaskColor
End Property

Public Property Let UseMaskColor(ByVal New_UseMaskColor As Boolean)
  cmd.UseMaskColor = New_UseMaskColor
  PropertyChanged "UseMaskColor"
End Property

Public Sub Refresh()
  cmd.Refresh
End Sub

Private Sub cmd_Click()
  RaiseEvent Click
End Sub

Private Sub cmd_KeyDown(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyDown(KeyCode, Shift)
End Sub

Private Sub cmd_KeyPress(KeyAscii As Integer)
  RaiseEvent KeyPress(KeyAscii)
End Sub

Private Sub cmd_KeyUp(KeyCode As Integer, Shift As Integer)
  RaiseEvent KeyUp(KeyCode, Shift)
End Sub

Private Sub cmd_MouseDown(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)

  RaiseEvent MouseDown(Button, Shift, X, Y)
  mCount = 0
  tmr.Enabled = False
  If Button = vbLeftButton Then
    tmr.Enabled = pRepeat
    If pRepeat Then
      RaiseEvent Repeat(0)
    End If
  End If
End Sub

Private Sub cmd_MouseMove(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)

  On Error Resume Next
  cmd.ToolTipText = Extender.ToolTipText
  On Error GoTo 0
  RaiseEvent MouseMove(Button, Shift, X, Y)
  If Button = vbLeftButton Then
    With cmd
      Select Case X
        Case 0 To .Width
          Select Case Y
            Case 0 To .Height
              With tmr
                If .Enabled = False Then
                  mCount = mCount + 1
                  .Enabled = True
                  RaiseEvent Repeat(mCount)
                End If
              End With
              Exit Sub
          End Select
      End Select
    End With
    tmr.Enabled = False
  End If
End Sub

Private Sub cmd_MouseUp(Button As Integer, Shift As Integer, _
 X As Single, Y As Single)

  tmr.Enabled = False
  mCount = 0
  RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub eFont_FontChanged(ByVal PropertyName As String)
  PropertyChanged "Font"
End Sub

Private Sub tmr_Timer()
  If GetFocus() <> cmd.hWnd Then
    tmr.Enabled = False
  Else
    mCount = mCount + 1
    RaiseEvent Repeat(mCount)
  End If
End Sub

Private Sub UserControl_Initialize()
  pRepeat = True
End Sub

Private Sub UserControl_InitProperties()
  cmd.Caption = Ambient.DisplayName
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  cmd.Caption = PropBag.ReadProperty("Caption", Ambient.DisplayName)
  Set cmd.DisabledPicture = _
   PropBag.ReadProperty("DisabledPicture", Nothing)
  Set cmd.DownPicture = PropBag.ReadProperty("DownPicture", Nothing)
  Me.Enabled = PropBag.ReadProperty("Enabled", True)
  Set Me.Font = PropBag.ReadProperty("Font", Ambient.Font)
  Me.Interval = PropBag.ReadProperty("Interval", 250)
  cmd.MaskColor = PropBag.ReadProperty("MaskColor", vbMagenta)
  Set cmd.MouseIcon = PropBag.ReadProperty("MouseIcon", Nothing)
  cmd.MousePointer = PropBag.ReadProperty("MousePointer", vbDefault)
  Set cmd.Picture = PropBag.ReadProperty("Picture", Nothing)
  pRepeat = PropBag.ReadProperty("Repeat", True)
  cmd.UseMaskColor = PropBag.ReadProperty("UseMaskColor", True)
End Sub

Private Sub UserControl_Resize()
  Static sInProc As Boolean
  
  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  With UserControl
    cmd.Move 0, 0, .ScaleWidth, .ScaleHeight
    .Size cmd.Width, cmd.Height
  End With
  sInProc = False
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "Caption", cmd.Caption, Ambient.DisplayName
  PropBag.WriteProperty "DisabledPicture", cmd.DisabledPicture, _
   Nothing
  PropBag.WriteProperty "DownPicture", cmd.DownPicture, Nothing
  PropBag.WriteProperty "Enabled", UserControl.Enabled, True
  PropBag.WriteProperty "Font", cmd.Font, Ambient.Font
  PropBag.WriteProperty "Interval", tmr.Interval, 250
  PropBag.WriteProperty "MaskColor", cmd.MaskColor, vbMagenta
  PropBag.WriteProperty "MouseIcon", cmd.MouseIcon, Nothing
  PropBag.WriteProperty "MousePointer", cmd.MousePointer, vbDefault
  PropBag.WriteProperty "Picture", cmd.Picture, Nothing
  PropBag.WriteProperty "Repeat", pRepeat, True
  PropBag.WriteProperty "UseMaskColor", cmd.UseMaskColor, True
End Sub

Das ActiveX-Control-Projekt RepeaterOCX (repeater.zip - ca. 4,8 KB)

					Copyright © 1999 - 2023 Harald M. Genauck, ip-pro gmbh / Impressum