Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0443: Bildschirmlupe mit StretchBlt realisieren

VB 5/6-Tipp 0443: Bildschirmlupe mit StretchBlt realisieren

 von Benjamin Wilger

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt, GetCursorPos, GetDC, GetDesktopWindow, GetWindowRect, ReleaseDC, StretchBlt

Download: Download des Beispielprojektes [2,78 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Projekt1.vbp -------------
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (mscomctl.ocx)' wird benötigt.

'--------- Anfang Formular "Form1" alias Form1.frm  ---------
' Steuerelement: Slider "Slider2"
' Steuerelement: Slider "Slider1"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Schaltfläche "Command1"
' Steuerelement: Bildfeld-Steuerelement "Picture1"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Beschriftungsfeld "Label1"

'Code von Benjamin Wilger
'Benjamin@ActiveVB.de
'Copyright (C) 2001
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 ' (DWORD) dest = source
Private Const SRCAND = &H8800C6 ' (DWORD) dest = source AND dest
Private Const SRCERASE = &H440328    ' (DWORD) dest = source AND (NOT dest )
Private Const SRCINVERT = &H660046    ' (DWORD) dest = source XOR dest
Private Const SRCPAINT = &HEE0086    ' (DWORD) 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 Slider2_Change()
    Timer1.Interval = 1000 / Slider2.Value
    Me.Caption = Int(1000 / Slider2.Value)
End Sub

Private Sub Slider2_Scroll()
    Timer1.Interval = 1000 / Slider2.Value
    Me.Caption = Int(1000 / Slider2.Value)
    
End Sub

Private Sub Timer1_Timer()
    Dim mPos As pointAPI
    Dim x As Integer, y As Integer, w As Integer, h As Integer, sw As Integer, 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
    
    'Vergrößerter Abschnitt anzeigen
    StretchBlt Picture1.hDC, 0, 0, w, h, DhDC, x, y, sw, sh, SRCCOPY
    
End Sub

'---------- Ende Formular "Form1" alias Form1.frm  ----------
'-------------- Ende Projektdatei Projekt1.vbp --------------