Tipp 034: Eine Bildschirmlupe mit StretchBlt realisieren

Form                     frmLupe
Label                    Label1
Label                    Label2
PictureBox               Picture1
Slider                   Slider1
Slider                   Slider2

' VISUAL BASIC WORLD
' ===========================================
' Das große Portal zum Thema Visual Basic.
'
' Wenn Ihnen dieser Source Code gefallen hat,
' dann empfehlen Sie Visual Basic World bitte
' weiter und/oder setzen Sie einen Link auf:
'
' http://www.visualbasicworld.de/
'
' Vernetzen Sie sich mit uns:
'
' http://twitter.com/visualbasicwrld
'
' Autor: Benjamin Wilger


Option Explicit
 
Private Declare Function GetDesktopWindow Lib "user32" () As Long
 
Private Declare Function BitBlt Lib "gdi32" _
   (ByVal hDestDC 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 dwRop 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 Declare Function GetDC Lib "user32" _
   (ByVal hwnd As Long) As Long
 
Private Declare Function ReleaseDC Lib "user32" _
   (ByVal hwnd As Long, ByVal hDC As Long) As Long
 
Private Declare Function GetCursorPos Lib "user32" _
   (lpPoint As pointAPI) As Long
 
Private Declare Function GetWindowRect Lib "user32" _
   (ByVal hwnd As Long, lpRect As RECT) As Long
 
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 Const SRCCOPY = &HCC0020 'dest = source
Private Const SRCAND = &H8800C6 'dest = source AND dest
Private Const SRCERASE = &H440328 'dest = source AND (NOT dest)
Private Const SRCINVERT = &H660046 'dest = source XOR dest
Private Const SRCPAINT = &HEE0086 'dest = source OR dest
 
Dim DhDC As Long
Dim DhWnd As Long

Private Sub Form_Load()
 
    Slider2.Value = 1000 / Timer1.Interval
    DhWnd = GetDesktopWindow
    DhDC = GetDC(DhWnd)
 
End Sub

Private Sub Form_Unload(Cancel As Integer)
 
    Call ReleaseDC(DhWnd, hDC)
 
End Sub

Private Sub Slider1_Change()
 
   Slider1_Scroll
 
End Sub

Private Sub Slider1_Scroll()
 
   Label1.Caption = "Vergrößerungsfaktor: " & Slider1.Value
 
End Sub

Private Sub Slider2_Change()
 
    Slider2_Scroll
 
End Sub

Private Sub Slider2_Scroll()
 
    Timer1.Interval = 1000 / Slider2.Value
    Label2.Caption = "Abtastrate: " & Int(1000 / Slider2.Value)
 
End Sub

Private Sub Timer1_Timer()
 
    Dim mPos As pointAPI
    Dim x As Integer
    Dim y As Integer
    Dim w As Integer
    Dim h As Integer
    Dim sw As Integer
    Dim sh As Integer
    Dim zoomVal As Integer
    GetCursorPos mPos
 
    Picture1.Cls
    Picture1.ScaleMode = vbPixels
 
    zoomVal = Slider1.Value
    w = Picture1.ScaleWidth
    h = Picture1.ScaleHeight
 
    sw = w * (1 / zoomVal)
    sh = h * (1 / zoomVal)
 
    x = mPos.x - sw \ 2
    y = mPos.y - sh \ 2
 
    StretchBlt Picture1.hDC, 0, 0, w, h, DhDC, x, y, sw, sh, SRCCOPY
      'Vergrößerten Abschnitt anzeigen.
 
End Sub