ABOUT Visual Basic - das Webmagazin: Und es hat Zoom gemacht... (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 Bildschirmlupe ist eigentlich nichts Besonderes. Ein paar wenige API-Funktionen zur Ermittlung des Gerätekontexts des Bildschirms und zum Kopieren eines Ausschnitts - mehr ist gar nicht notwendig: GetDesktopWindow, GetDC/ReleaseDC und StretchBlt. Zur Ermittlung der aktuellen Position des Mauszeigers kommt noch GetCursorPos hinzu. Anhand der Größe der Fläche, in die das vergrößerte Abbild des Bildschirminhalts kopiert werden soll, wird entsprechend dem Vergrößerungsfaktor die Größe des Bildschirmausschnitts ermittelt. Dessen Position ergibt sich aus der Position des Mauszeigers - um die Hälfte seiner Größe nach links und nach oben verschoben, damit er mittig über diesem liegt. Falls dieser Bildschirmausschnitt über die Grenzen des Bildschirms hinausragen sollte, wird der ungültige Bereich mit der Hintergrundfarbe übermalt und der Ausschnitt entsprechend beschnitten.



	Eine Bildschirmlupe als ActiveX-Steuerelement

Für die regelmäßige Aktualisierung des Lupenausschnitts sorgt ein Timer mit verhältnismäßig kurzen Intervallen (natürlich einstellbar über die Eigenschaft Interval). Die Vergrößerung kann in festen Schritten eingestellt werden: 1x, 2x, 4x, 8x, 16x und 32x. Diese Beschränkung ist sinnvoll, da die Vergrößerung von Pixelbildern in "krummen" Werten keine sehr ansehnlichen Ergebnisse bringt. Über die Eigenschaft Picture kann jederzeit ein Schnappschuss als Picture-Objekt ausgelesen werden. Ob jede Aktualisierung mit einem Ereignis ("SnapShot") gemeldet werden soll, wird über die Eigenschaft Events festgelegt. Wird die Eigenschaft Frozen auf True gesetzt, wird das Bild eingefroren und nicht weiter aktualisiert.

Die Hintergrundfarbe wird über BackColor festgelegt, und der Rahmenstil (flach oder 3D) über die Eigenschaft BorderStyle. Die Align-Eigenschaft sorgt wie etwa bei der PictureBox dafür, dass das Steuerelement am Rand seines Containers angedockt wird und seine Größe mit diesem ändert. Generell wird die Änderung der Größe durch das Resize-Ereignis gemeldet und die aktuellen Innenmaße der Abbildungsfläche können über die Eigenschaften ScaleWidth und ScaleHeight ausgelesen werden. Schließlich gibt es noch die üblichen Maus-Ereignisse (Click, DblClick, MouseDown, MouseMove und MouseUp). Das Steuerelement kann selbst nicht den Fokus erhalten - wozu auch.

Zu guter Letzt gibt es noch die (einzige steuerelement-spezifische) Methode Clear, die den Inhalt der Anzeige löscht. Dies wirkt sich natürlich nur aus, wenn die Lupenfunktion eingefroren ist oder das Intervall auf 0 gesetzt ist.

Private Type POINTAPI
  X As Long
  Y As Long
End Type

Private Declare Function GetCursorPos Lib "user32" _
 (lpPoint As POINTAPI) As Long
Private Declare Function GetDC Lib "user32" _
 (ByVal hwnd As Long) As Long
Private Declare Function GetDesktopWindow _
 Lib "user32" () As Long
Private Declare Function ReleaseDC Lib "user32" _
 (ByVal hwnd As Long, ByVal hdc 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 kInterval = 50

Public Event Click()
Public Event DblClick()
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 Resize()
Public Event SnapShot()

Public Enum mfBorderStyleConstants
  mfBSFlat
  mfBSSingle
End Enum

Public Enum mfZoomConstants
  mfZoom1x = 1
  mfZoom2x = 2
  mfZoom4x = 4
  mfZoom8x = 8
  mfZoom16x = 16
  mfZoom32x = 32
End Enum

Private pEvents As Boolean
Private pFrozen As Boolean
Private pZoom As mfZoomConstants

Public Property Get BackColor() As OLE_COLOR
  BackColor = UserControl.BackColor
End Property

Public Property Let BackColor(ByVal New_BackColor As OLE_COLOR)
  UserControl.BackColor = New_BackColor
  PropertyChanged "BackColor"
End Property

Public Property Get BorderStyle() As mfBorderStyleConstants
  BorderStyle = UserControl.BorderStyle
End Property

Public Property Let BorderStyle(ByVal New_BorderStyle _
 As mfBorderStyleConstants)

  UserControl.BorderStyle = New_BorderStyle
  PropertyChanged "BorderStyle"
End Property

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

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

Public Property Get Events() As Boolean
  Events = pEvents
End Property

Public Property Let Events(ByVal New_Events As Boolean)
  pEvents = New_Events
  PropertyChanged "Events"
End Property

Public Property Get Frozen() As Boolean
  Frozen = pFrozen
End Property

Public Property Let Frozen(ByVal New_Frozen As Boolean)
  pFrozen = New_Frozen
  If Ambient.UserMode Then
    tmr.Enabled = Not pFrozen
    zGetImage
  End If
  PropertyChanged "Frozen"
End Property

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

Public Property Let Interval(ByVal New_Interval As Long)
  tmr.Interval = New_Interval
  PropertyChanged "Interval"
End Property

Public Property Get Picture() As StdPicture
  Static sInProc As Boolean
  
  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  With UserControl
    .AutoRedraw = True
    zGetImage
    Set Picture = .Image
    .AutoRedraw = False
  End With
  sInProc = False
End Property

Public Property Get ScaleHeight() As Long
  ScaleHeight = UserControl.ScaleHeight
End Property

Public Property Get ScaleWidth() As Long
  ScaleWidth = UserControl.ScaleWidth
End Property

Public Property Get Zoom() As mfZoomConstants
  Zoom = pZoom
End Property

Public Property Let Zoom(ByVal New_Zoom As mfZoomConstants)
  Select Case New_Zoom
    Case mfZoom1x, mfZoom2x, mfZoom4x, mfZoom8x, mfZoom16x, _
     mfZoom32x
      pZoom = New_Zoom
    Case Else
      Err.Raise 380
  End Select
  PropertyChanged "Zoom"
End Property

Public Sub Clear()
  UserControl.Cls
End Sub

Private Sub tmr_Timer()
  zGetImage
  If pEvents Then
    RaiseEvent SnapShot
  End If
End Sub

Private Sub UserControl_Click()
  RaiseEvent Click
End Sub

Private Sub UserControl_DblClick()
  RaiseEvent DblClick
End Sub

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

  RaiseEvent MouseDown(Button, Shift, X, Y)
End Sub

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

  RaiseEvent MouseMove(Button, Shift, X, Y)
End Sub

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

  RaiseEvent MouseUp(Button, Shift, X, Y)
End Sub

Private Sub UserControl_Initialize()
  Me.Zoom = mfZoom2x
  tmr.Interval = kInterval
End Sub

Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  UserControl.BackColor = PropBag.ReadProperty("BackColor", _
   vbApplicationWorkspace)
  UserControl.BorderStyle = PropBag.ReadProperty("BorderStyle", _
   mfBSSingle)
  UserControl.Enabled = PropBag.ReadProperty("Enabled", True)
  pEvents = PropBag.ReadProperty("Events", False)
  Me.Interval = PropBag.ReadProperty("Interval", kInterval)
  Me.Frozen = PropBag.ReadProperty("Frozen", False)
  Me.Zoom = PropBag.ReadProperty("Zoom", mfZoom2x)
  If Ambient.UserMode Then
    Set UserControl.Picture = Nothing
  End If
End Sub

Private Sub UserControl_Resize()
  RaiseEvent Resize
End Sub

Private Sub UserControl_Show()
  If Ambient.UserMode Then
    zGetImage
  End If
End Sub

Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  PropBag.WriteProperty "BackColor", UserControl.BackColor, _
   vbApplicationWorkspace
  PropBag.WriteProperty "BorderStyle", UserControl.BorderStyle, _
   mfBSSingle
  PropBag.WriteProperty "Enabled", UserControl.Enabled, True
  PropBag.WriteProperty "Events", pEvents, False
  PropBag.WriteProperty "Frozen", pFrozen, False
  PropBag.WriteProperty "Interval", tmr.Interval, kInterval
  PropBag.WriteProperty "Zoom", pZoom, mfZoom2x
End Sub

Private Sub zGetImage()
  Dim nPoint As POINTAPI
  Dim nDesktopWnd As Long
  Dim nDesktopDC As Long
  Dim nScaleHeight As Long
  Dim nScaleWidth As Long
  Dim nScaleHeight2 As Long
  Dim nScaleWidth2 As Long
  Dim nSnapShotWidth As Long
  Dim nSnapShotHeight As Long
  Dim nSnapShotLeft As Long
  Dim nSnapShotTop As Long
  Dim nLeft As Long
  Dim nTop As Long
  Dim nRight As Long
  Dim nBottom As Long
  
  Static sInProc As Boolean
  
  If sInProc Then
    Exit Sub
  Else
    sInProc = True
  End If
  With UserControl
    GetCursorPos nPoint
    nScaleWidth = .ScaleWidth
    nScaleWidth2 = nScaleWidth
    nSnapShotWidth = nScaleWidth / pZoom
    nScaleHeight = .ScaleHeight
    nScaleHeight2 = nScaleHeight
    nSnapShotHeight = nScaleHeight / pZoom
    nSnapShotLeft = nPoint.X - (nSnapShotWidth \ 2)
    If nSnapShotLeft < 0 Then
      nLeft = -nSnapShotLeft * pZoom
      nScaleWidth = nScaleWidth - nLeft
      UserControl.Line (0, 0)-(nLeft - 1, nScaleHeight2), _
       .BackColor, BF
      nSnapShotWidth = nSnapShotWidth + nSnapShotLeft
      nSnapShotLeft = 0
    End If
    nSnapShotTop = nPoint.Y - (nSnapShotHeight \ 2)
    If nSnapShotTop < 0 Then
      nTop = -nSnapShotTop * pZoom
      nScaleHeight = nScaleHeight - nTop
      UserControl.Line (0, 0)-(nScaleWidth2, nTop - 1), _
       .BackColor, BF
      nSnapShotHeight = nSnapShotHeight + nSnapShotTop
      nSnapShotTop = 0
    End If
    nRight = (Screen.Width \ Screen.TwipsPerPixelX) - _
     (nSnapShotLeft + nSnapShotWidth)
    If nRight < 0 Then
      nSnapShotWidth = nSnapShotWidth + nRight
      UserControl.Line (nScaleWidth2 + _
       (nRight * pZoom), 0)-Step(-nRight * pZoom, nScaleHeight2), _
       .BackColor, BF
      nScaleWidth = nScaleWidth2 + (nRight * pZoom)
    End If
    nBottom = (Screen.Height \ Screen.TwipsPerPixelY) - _
     (nSnapShotTop + nSnapShotHeight)
    If nBottom < 0 Then
      nSnapShotHeight = nSnapShotHeight + nBottom
      UserControl.Line (0, nScaleHeight2 + _
       (nBottom * pZoom))-Step(nScaleWidth2, -nBottom * pZoom), _
       .BackColor, BF
      nScaleHeight = nScaleHeight2 + (nBottom * pZoom)
    End If
    nDesktopDC = GetDC(nDesktopWnd)
    StretchBlt .hdc, nLeft, nTop, nScaleWidth, nScaleHeight, _
     nDesktopDC, nSnapShotLeft, nSnapShotTop, nSnapShotWidth, _
     nSnapShotHeight, vbSrcCopy
    ReleaseDC nDesktopWnd, nDesktopDC
  End With
  sInProc = False
End Sub

Das Projekt avbMagnifier (magnifier.zip - ca. 8,5 KB)