ABOUT Visual Basic - das Webmagazin: Cursor im Fadenkreuz (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)

Aufgrund der Transparenz-Fähigkeit des UserControls können Sie auf recht einfache Weise einen Fadenkreuz-Cursor erzeugen. Es genügen zwei Line-Steuerelemente, die auf dem durchsichtigen UserControl vertikal und horizontal positioniert werden. Dabei umgrenzt das UserControl selbst die Fläche, innerhalb derer der Fadenkreuz-Cursor erscheinen soll. Sinnvollerweise ist das die Fläche des Containers, auf dem das Fadenkreuz-Steuerlement platziert ist (die Einpassung in dessen Fläche müssen Sie allerdings selbst vornehmen).



	Ein Fadenkreuz auf der Basis eines UserControls

Die Eigenschaften Color, DrawMode und Style legen das Aussehen des Fadenkreuzes fest. DrawMode entspricht dabei der DrawMode-Eigenschaft der Line-Steuerelemente, und Style deren BorderStyle-Eigenschaft. Die Eigenschaft Enabled schaltet die Bewegung des Fadenkreuzes ein bzw. aus.

Über die Eigenschaften X und Y können Sie die horizontale und die vertikale Position des Fadenkreuzes separat setzen und auslesen, über die Methode SetPos setzen Sie beide Koordinaten auf einmal.

Damit die Linien des Fadenkreuzes bei schnellen Mausbewegungen nicht vor dem Rand hängen bleiben, ist über die schlichte Positionierung hinaus ein wenig Aufwand mehr notwendig. Das funktioniert auch, wenn sich über dem UserControl andere Steuerelemente befinden sollten, etwa CommandButtons, Labels, Bildelemente und dergleichen. Es wird automatisch erkannt, ob sich die Position des Mauszeigers innerhalb des vom UserControl umgrenzten Bereichs befindet. Ist dies der Fall, gibt die SetPos-Methode True zurück. Schauen wir uns daher diese Methode etwas näher an.

Public Function SetPos(ByVal X As Single, ByVal Y As Single, _
 Optional ByVal hWnd As Long) As Boolean

  Dim nWnd As Long
  Dim nPoint As POINTAPI
  Dim nScreenPoint As POINTAPI
  Dim nRect As RECT
  Dim nExit As Boolean

Ist die Eigenschaft auf Enabled auf True gesetzt, werden zunächst die Linien positioniert. Es genügt, die X-Koordinaten der vertikalen Linie (lnV) und die Y-Koordinaten der horizontalen Linie (lnH) zu setzen. Die jeweils zweiten Koordinaten werden automatisch bei Größenänderungen des UserControls (siehe Resize-Ereignis) nachgeführt.

  If Enabled Then
    With lnV
      .X1 = X
      .X2 = X
    End With
    With lnH
      .Y1 = Y
      .Y2 = Y
    End With

Zur Prüfung, ob sich die Position des Mauszeigers innerhalb des Containers befindet, auf dem das Fandekreuz-Steuerelement platziert ist, wird dessen Fenster-Handle benötigt. Dieses können Sie in der separaten Eigenschaft Wnd vorgeben oder im optionalen Parameter hWnd der SetPos-Methode übergeben.

    If hWnd = 0 Then
      nWnd = pWnd
    Else
      nWnd = hWnd
    End If

Fehlt das Handle, oder ist dessen Wert 0 (kein Fenster), wird der weitere Code nicht ausgeführt - es bleibt bei der schlichten Positionierung des Fadenkreuzes.

    If nWnd Then

Mittels der API-Funktion GetCursorPos ermitteln wir die tatsächliche Position des Mauszeigers auf dem Bildschirm.

    GetCursorPos nPoint

Wir merken uns dessen Koordinaten zur späteren Wiederverwendung in einer zweiten POINTAPI-Variablen, in nScreenPoint.

    LSet nScreenPoint = nPoint

Zur Prüfung, ob sich der Punkt innerhalb des Client-Bereichs (Arbeitsfläche) des Containers befindet, lassen wir die Koordinaten von der API-Funktion ScreenToClient in Client-Koordinaten umrechnen.

    ScreenToClient nWnd, nPoint

Dann ermitteln wir mit der API-Funktion GetClientRect den Client-Bereich des Containers.

    GetClientRect nWnd, nRect

Liegt der Punkt innerhalb des Client-Rechtecks,

    With nPoint
    If PtInRect(nRect, .X, .Y) Then
      With nScreenPoint

prüfen wir weiterhin, ob das Fenster unter dem Punkt mit den ursprünglichen Bildschirm-Koordinaten das Fenster mit dem oben festgelegten Fenster-Handle ist.

      If WindowFromPoint(.X, .Y) = nWnd Then

Ist dies der Fall, fangen wir den Mauszeiger für dieses Fenster (also den Container) mit der API-Funktion SetCapture ein, setzen den Rückgabewert der SetPos-Methode auf True und vermerken in der Variablen nExit, dass die Funktion weiter unten vorzeitig verlassen werden kann.

        SetCapture nWnd
        SetPos = True
        nExit = True
      End If
      End With

Unabhängig davon, ob sich der Mauszeiger über dem Container befindet lösen wir das für das UserControl definierte Ereignis MouseMove aus, das die Client-Koordinaten in Twips mitliefert.

      RaiseEvent MouseMove(.X * Screen.TwipsPerPixelX, _
       .Y * Screen.TwipsPerPixelY)

Ist der Vermerk in nExit gesetzt, wird die Methode verlassen.

      If nExit Then
      Exit Function
      End If
    End If
    End With
  End If
  End If

Lag der Punkt nicht innerhalb des Client-Bereichs oder ist Enabled gleich False, wird der gegebenenfalls noch von einem früheren Aufruf der SetPos-Methode her eingefangene Mauszeiger (Prüfung mit GetCapture) wieder mit ReleaseCapture freigegeben.

  If GetCapture() = nWnd Then
    ReleaseCapture
  End If

End Function

Noch einmal zur Verdeutlichung, wir unterscheiden hier drei Fälle: Erstens - ob sich der Mauszeiger innerhalb des Containers befindet und dass sich kein anderes Steuerelement auf dem Container unter dem Mauszeiger befindet. Zweitens - ob sich der Mauszeiger innerhalb des Containers befindet, jedoch über einem Steuerelement, das auf dem Container platziert ist. Und drittens, ob sich der Mauszeiger außerhalb des Containers befindet.

Ein Steuerelement, das sich zwischen Mauszeiger und Container befindet, muss nicht unbedingt im eigentlichen Sinne auf dem Container platziert sein. Es genügt, dass es auch nur in diesen hineinragt. Damit das Fadenkreuz auch entsprechend positioniert werden kann, müssen Sie aus dem MouseMove-Ereignis eines solchen Steuerlements die SetPos-Methode ebenfalls aufrufen, natürlich mit den entsprechend umgerechneten Koordinaten (siehe Beispiel-Projekt, das sie mit dem Fadenkreuz-Steuerelement herunterladen können).

Da es bei einem Fadenkreuz auch wenig Sinn hätte, dass es den Fokus erhalten kann, sind die UserControl-Eigenschaften Enabled und CanGetFocus auf False gesetzt. Damit sich das UserControl ähnlich wie Label- oder Image-Stauerelemente immer hinter anderen Steuerelementen auf der untersten Ebene des Containers befindet, ist seine Windowless-Eigenschaft auf True gesetzt. Dadurch ist es allerdings nicht mehr möglich, im Design-Modus das auf einem Container platzierte UserControl mit der Maus auszuwählen und zu verschieben. Um Ihnen eine bequemere Positionierung als über die Left- und Top-Eigenschaften im Eigenschaften-Fenster zu ermöglichen, dient die nur im Design-Modus (Ambient.UserMode = False) aktive Eigenschaft Opaque. Wird diese auf True gesetzt, verliert das UserControl vorübergehend seine Durchsichtigkeit und kann dann wie gewohnt mit der Maus positioniert werden.

Public Property Get Opaque() As Boolean
  If Ambient.UserMode Then
  Err.Raise 393
  Else
  Opaque = CBool(UserControl.BackStyle)
  End If
End Property

Public Property Let Opaque(ByVal New_Opaque As Boolean)
  If Ambient.UserMode Then
  Err.Raise 382
  Else
  UserControl.BackStyle = Abs(New_Opaque)
  End If
End Property

Hier nun der vollständige Code des Fadenkreuz-Steuerelements:

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Type RECT
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Declare Function GetCapture Lib "user32" () As Long
Private Declare Function GetClientRect Lib "user32" _
 (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetCursorPos Lib "user32" _
 (lpPoint As POINTAPI) As Long
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, _
 ByVal ptx As Long, ByVal pty As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function ScreenToClient Lib "user32" _
 (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SetCapture Lib "user32" _
 (ByVal hWnd As Long) As Long
Private Declare Function WindowFromPoint Lib "user32" _
 (ByVal xPoint As Long, ByVal yPoint As Long) As Long

Public Event MouseMove(ByVal X As Single, ByVal Y As Single)

Public Enum CrossHairDrawModeConstants
  chBlackness = vbBlackness
  chNotMergePen = vbNotMergePen
  chMaskNotPen = vbMaskNotPen
  chNotCopyPen = vbNotCopyPen
  chMaskPenNot = vbMaskPenNot
  chInvert = vbInvert
  chXorPen = vbXorPen
  chNotMaskPen = vbNotMaskPen
  chMaskPen = vbMaskPen
  chNotXorPen = vbNotXorPen
  chNop = vbNop
  chMergeNotPen = vbMergeNotPen
  chCopyPen = vbCopyPen
  chMergePenNot = vbMergePenNot
  chMergePen = vbMergePen
  chWhiteness = vbWhiteness
End Enum

Public Enum CrossHairBorderStyleConstants
  chBSSolid = vbBSSolid
  chBSDash = vbBSDash
  chBSDot = vbBSDot
  chBSDashDot = vbBSDashDot
  chBSDashDotDot = vbBSDashDotDot
End Enum

Private pEnabled As Boolean
Private pWnd As Long

Public Property Get Color() As OLE_COLOR
  Color = lnV.BorderColor
End Property

Public Property Let Color(ByVal New_Color As OLE_COLOR)
  lnV.BorderColor = New_Color
  lnH.BorderColor = New_Color
  PropertyChanged "Color"
End Property

Public Property Get DrawMode() As CrossHairDrawModeConstants
  DrawMode = lnV.DrawMode
End Property

Public Property Let DrawMode(ByVal New_DrawMode _
 As CrossHairDrawModeConstants)

  Select Case New_DrawMode
    Case lnV.DrawMode
    Case chBlackness To chWhiteness
      lnV.DrawMode = New_DrawMode
      lnH.DrawMode = New_DrawMode
      PropertyChanged "DrawMode"
    Case Else
      Err.Raise 380
  End Select
End Property

Public Property Get Enabled() As Boolean
  Enabled = pEnabled
End Property

Public Property Let Enabled(ByVal New_Enabled As Boolean)
  pEnabled = New_Enabled
  PropertyChanged "Enabled"
End Property

Public Property Get Style() As CrossHairBorderStyleConstants
  Style = lnV.BorderStyle
End Property

Public Property Let Style(ByVal New_Style _
 As CrossHairBorderStyleConstants)

  Select Case New_Style
    Case lnV.BorderStyle
    Case chBSSolid To chBSDashDotDot
      lnV.BorderStyle = New_Style
      lnH.BorderStyle = New_Style
      PropertyChanged "Style"
    Case Else
      Err.Raise 380
  End Select
End Property

Public Property Get Opaque() As Boolean
  If Ambient.UserMode Then
    Err.Raise 393
  Else
    Opaque = CBool(UserControl.BackStyle)
  End If
End Property

Public Property Let Opaque(ByVal New_Opaque As Boolean)
  If Ambient.UserMode Then
    Err.Raise 382
  Else
    UserControl.BackStyle = Abs(New_Opaque)
  End If
End Property

Public Property Get Wnd() As Long
  Wnd = pWnd
End Property

Public Property Let Wnd(ByVal New_Wnd As Long)
  pWnd = New_Wnd
End Property

Public Property Get X() As Single
  X = lnV.X1
End Property

Public Property Let X(New_X As Single)
  SetPos New_X, lnH.Y1
  PropertyChanged "X"
End Property

Public Property Get Y() As Single
  Y = lnH.Y1
End Property

Public Property Let Y(New_Y As Single)
  SetPos lnV.X1, New_Y
  PropertyChanged "Y"
End Property

Public Function SetPos(ByVal X As Single, ByVal Y As Single, _
 Optional ByVal hWnd As Long) As Boolean

  Dim nWnd As Long
  Dim nPoint As POINTAPI
  Dim nScreenPoint As POINTAPI
  Dim nRect As RECT
  Dim nExit As Boolean
  
  If Enabled Then
    With lnV
      .X1 = X
      .X2 = X
    End With
    With lnH
      .Y1 = Y
      .Y2 = Y
    End With
    If hWnd = 0 Then
      nWnd = pWnd
    Else
      nWnd = hWnd
    End If
    If nWnd Then
      GetCursorPos nPoint
      LSet nScreenPoint = nPoint
      ScreenToClient nWnd, nPoint
      GetClientRect nWnd, nRect
      With nPoint
        If PtInRect(nRect, .X, .Y) Then
          With nScreenPoint
            If WindowFromPoint(.X, .Y) = nWnd Then
              SetCapture nWnd
              SetPos = True
              nExit = True
            End If
          End With
          RaiseEvent MouseMove(.X * Screen.TwipsPerPixelX, _
           .Y * Screen.TwipsPerPixelY)
          If nExit Then
            Exit Function
          End If
        End If
      End With
    End If
  End If
  If GetCapture() = nWnd Then
    ReleaseCapture
  End If
End Function

Private Sub UserControl_Initialize()
  pEnabled = True
End Sub

Private Sub UserControl_InitProperties()
  With lnV
    .X1 = -Screen.TwipsPerPixelX
    .X2 = -Screen.TwipsPerPixelX
  End With
  With lnH
    .Y1 = -Screen.TwipsPerPixelY
    .Y2 = -Screen.TwipsPerPixelY
  End With
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  Dim nX As Single
  Dim nY As Single
  
  Me.Color = PropBag.ReadProperty("Color", vbBlack)
  Me.DrawMode = PropBag.ReadProperty("DrawMode", chCopyPen)
  pEnabled = PropBag.ReadProperty("Enabled", True)
  Me.Style = PropBag.ReadProperty("Style", chBSSolid)
  nX = PropBag.ReadProperty("X", -Screen.TwipsPerPixelX)
  nY = PropBag.ReadProperty("Y", -Screen.TwipsPerPixelY)
  Me.SetPos nX, nY
End Sub

Private Sub UserControl_Resize()
  On Error Resume Next
  With UserControl
    lnV.Y1 = -2 * Screen.TwipsPerPixelY
    lnV.Y2 = .ScaleHeight + 2 * Screen.TwipsPerPixelY
    lnH.X1 = -2 * Screen.TwipsPerPixelX
    lnH.X2 = .ScaleWidth + 2 * Screen.TwipsPerPixelX
  End With
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "Color", lnV.BorderColor, vbBlack
  PropBag.WriteProperty "DrawMode", lnV.DrawMode, chCopyPen
  PropBag.WriteProperty "Enabled", pEnabled, True
  PropBag.WriteProperty "Style", lnV.BorderStyle, chBSSolid
  PropBag.WriteProperty "X", lnV.X1, -Screen.TwipsPerPixelX
  PropBag.WriteProperty "Y", lnH.Y1, -Screen.TwipsPerPixelY
End Sub

Das Projekt avbCrossHair (crosshair.zip - ca. 26KB)