frmmain.frm

一个可以抓图的程序

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmMain 
   Caption         =   "Sanp Window Demo"
   ClientHeight    =   5190
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   7080
   BeginProperty Font 
      Name            =   "宋体"
      Size            =   9
      Charset         =   134
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   LinkTopic       =   "Form1"
   ScaleHeight     =   5190
   ScaleWidth      =   7080
   StartUpPosition =   2  'CenterScreen
   Begin MSComDlg.CommonDialog cdlg 
      Left            =   30
      Top             =   4680
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "保存图片(&S)"
      Height          =   345
      Left            =   150
      TabIndex        =   7
      Top             =   3330
      Width           =   1200
   End
   Begin VB.HScrollBar HScroll1 
      Height          =   270
      Left            =   1575
      TabIndex        =   5
      Top             =   4920
      Width           =   1245
   End
   Begin VB.VScrollBar VScroll1 
      Height          =   1245
      Left            =   6810
      TabIndex        =   4
      Top             =   0
      Width           =   270
   End
   Begin VB.PictureBox picSnap 
      AutoSize        =   -1  'True
      Height          =   480
      Left            =   390
      Picture         =   "frmMain.frx":0000
      ScaleHeight     =   420
      ScaleWidth      =   465
      TabIndex        =   2
      Top             =   1410
      Width           =   525
   End
   Begin VB.CheckBox chk 
      Caption         =   "抓图时最小化窗体(&M)"
      Height          =   495
      Left            =   150
      TabIndex        =   1
      Top             =   2100
      Value           =   1  'Checked
      Width           =   1200
   End
   Begin VB.Timer tmr 
      Enabled         =   0   'False
      Interval        =   400
      Left            =   540
      Top             =   4710
   End
   Begin VB.PictureBox picScroll 
      Height          =   4920
      Left            =   1575
      ScaleHeight     =   4860
      ScaleWidth      =   5175
      TabIndex        =   0
      Top             =   0
      Width           =   5235
      Begin VB.PictureBox picBmp 
         AutoRedraw      =   -1  'True
         BorderStyle     =   0  'None
         Height          =   2805
         Left            =   0
         ScaleHeight     =   2805
         ScaleWidth      =   3825
         TabIndex        =   6
         Top             =   0
         Width           =   3825
      End
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      Caption         =   "左键点击图片，然后按住不放拖动鼠标到需要捕获的窗口。"
      Height          =   900
      Left            =   150
      TabIndex        =   3
      Top             =   240
      Width           =   1200
      WordWrap        =   -1  'True
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

'--------------------------------------
'        抓图的源程序
'
' 可以实现指定窗口的图形的捕获
' 若有任何问题可以与我联系
'
' 作者:     李辉
' 个人主页: http://vbfighter.126.com
' Email:    [e-mail]
'--------------------------------------

' API Declare
Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Type POINTAPI
        X As Long
        Y As Long
End Type

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 WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function SetROP2 Lib "gdi32" (ByVal hdc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function GetROP2 Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function Rectangle Lib "gdi32" (ByVal hdc As Long, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetCapture Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseCapture Lib "user32" () As Long
Private Declare Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnclip As Long, ByVal fdwOptions As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function SetActiveWindow Lib "user32" (ByVal hwnd As Long) As Long

Dim SnapHwnd&
Dim DeskHwnd&, DeskDC&
Dim oldRop2&
Dim rc As RECT
Dim meStates As Long

'---------------------------------------------------------------
' 保存位图
Private Sub cmdSave_Click()
    cdlg.InitDir = App.Path
    cdlg.Filter = "位图文件 (*.Bmp)|*.Bmp"
    cdlg.ShowOpen
    
    If Len(cdlg.FileName) = 0 Then Exit Sub
    
    Dim Msg$
    Msg$ = vbYes
    If Dir(cdlg.FileName) <> "" Then
        Msg$ = MsgBox("文件已经存在，是否覆盖文件？", vbYesNo + vbQuestion, "询问")
    End If
    
    Select Case Msg
        Case vbYes
            VB.SavePicture picBmp.Image, cdlg.FileName
        Case vbNo
    End Select
End Sub
'---------------------------------------------------------------


'---------------------------------------------------------------
' 实现可以滚动的效果
Private Sub Form_Resize()
    On Local Error Resume Next
    If WindowState <> vbMinimized Then
        meStates = Me.WindowState
        
        picScroll.Width = Me.ScaleWidth - 1845
        picScroll.Height = Me.ScaleHeight - 270

        HScroll1.Top = picScroll.Height
        HScroll1.Width = picScroll.Width
        VScroll1.Left = picScroll.Left + picScroll.Width
        VScroll1.Height = picScroll.Height

        If picScroll.Width > picBmp.Width Then
            HScroll1.Visible = False
        Else
            HScroll1.Visible = True
            HScroll1.Value = 0
            HScroll1.Max = picBmp.Width - picScroll.Width + 60
            HScroll1.LargeChange = picScroll.Width \ 3
            HScroll1.SmallChange = Screen.TwipsPerPixelX
            If HScroll1.LargeChange = 0 Then HScroll1.LargeChange = HScroll1.SmallChange
        End If
        If picScroll.Height > picBmp.Height Then
            VScroll1.Visible = False
        Else
            VScroll1.Visible = True
            VScroll1.Value = 0
            VScroll1.Max = picBmp.Height - picScroll.Height + 60
            VScroll1.LargeChange = picScroll.Height \ 3
            VScroll1.SmallChange = Screen.TwipsPerPixelY
            If VScroll1.LargeChange = 0 Then VScroll1.LargeChange = VScroll1.SmallChange
        End If
    End If
End Sub

Private Sub HScroll1_Change()
    picBmp.Left = -HScroll1.Value
End Sub

Private Sub HScroll1_Scroll()
    HScroll1_Change
End Sub

Private Sub VScroll1_Change()
    picBmp.Top = -VScroll1.Value
End Sub

Private Sub VScroll1_Scroll()
    VScroll1_Change
End Sub
'---------------------------------------------------------------


'---------------------------------------------------------------
' 开始抓图
Private Sub picSnap_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        If chk.Value = vbChecked Then Me.WindowState = vbMinimized
                
        SetCapture picSnap.hwnd     ' 让 picSnap 得到鼠标的捕获
        ''
        tmr.Enabled = True
    End If
End Sub

Private Sub picSnap_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbLeftButton Then
        tmr.Enabled = False        '
        
        If SnapHwnd& = 0 Then Exit Sub
        
        ' 保证 picBmp 的大小与捕捉到的DC大小相等
        picBmp.Left = 0
        picBmp.Top = 0
        picBmp.Width = (rc.Right - rc.Left) * 15
        picBmp.Height = (rc.Bottom - rc.Top) * 15
        
        '''
        Dim TempDC&
        Dim newBmp&, oldBmp&
        
        DeskHwnd& = GetDesktopWindow()
        DeskDC& = GetWindowDC(DeskHwnd&)
        
        TempDC& = CreateCompatibleDC(DeskDC&)
        
        newBmp& = CreateCompatibleBitmap(DeskDC, _
                    rc.Right - rc.Left, rc.Bottom - rc.Top)
        oldBmp& = SelectObject(TempDC, newBmp)
        
        ' 将捕捉到的DC保存到临时的DC中
        BitBlt TempDC, 0, 0, rc.Right - rc.Left, rc.Bottom - rc.Top, _
            DeskDC, rc.Left, rc.Top, vbSrcCopy
        
        Me.WindowState = meStates
                
        ' 将临时DC中图形显示到picBmp中
        BitBlt picBmp.hdc, 0, 0, _
            rc.Right - rc.Left, rc.Bottom - rc.Top, _
            TempDC, 0, 0, vbSrcCopy
        
        ' 释放系统的资源
        SelectObject TempDC, oldBmp
        DeleteObject newBmp: newBmp = 0
        DeleteDC TempDC
        ReleaseDC DeskHwnd, DeskDC: DeskDC = 0
        
        ' 因为 picBmp.AutoRedraw = True
        ' 所以必须使用Refresh方法，图形才会出现
        picBmp.Refresh
        ReleaseCapture      '释放鼠标的捕获
        Call Form_Resize    '
        Me.SetFocus
    End If
End Sub
'---------------------------------------------------------------


'---------------------------------------------------------------
' 让被捕捉到的窗口出现闪烁的矩形，
' 已提醒用户是哪一个窗口被程序所捕获
Private Sub tmr_Timer()
    Dim pnt As POINTAPI
    Dim newPen&, oldPen&
    
    ' Get desktop window dc
    DeskHwnd& = GetDesktopWindow()
    DeskDC& = GetWindowDC(DeskHwnd&)
    '
    oldRop2& = SetROP2(DeskDC&, 10)
    ' Get cursor position
    GetCursorPos pnt
    ' Get current window handle
    SnapHwnd = WindowFromPoint(pnt.X, pnt.Y)
    ' Get window rect
    GetWindowRect SnapHwnd, rc
    ' rc must in the DeskopWindow
    If rc.Left < 0 Then rc.Left = 0
    If rc.Top < 0 Then rc.Top = 0
    If rc.Right > Screen.Width / 15 Then rc.Right = Screen.Width / 15
    If rc.Bottom > Screen.Height / 15 Then rc.Bottom = Screen.Height / 15
    ' Create new pen and select it into the DeskDC
    newPen& = CreatePen(0, 3, &H0)
    oldPen& = SelectObject(DeskDC, newPen)
    ' Draw falsh rect
    Rectangle DeskDC, rc.Left, rc.Top, rc.Right, rc.Bottom
    Sleep tmr.Interval
    Rectangle DeskDC, rc.Left, rc.Top, rc.Right, rc.Bottom
    
    ' Release
    SetROP2 DeskDC, oldRop2
    SelectObject DeskDC, oldPen
    DeleteObject newPen
    ReleaseDC DeskHwnd, DeskDC: DeskDC = 0
End Sub
'---------------------------------------------------------------