'======================================================================================
'= 邮箱：freeforever@sohu.com =
'= useforprogram@126.com =
'= 此程序是为我的手机而写，用来在屏幕上抓图（128X128，我手机图片的大小） =
'= 2005-8-5 =
'======================================================================================
'2005-07-21更新:与AcdSee3.1配合使用抓图时使其变慢，原因是取得设备的DC后没有释放
Option Explicit
'坐标类
Private Type POINTAPI
X As Long
Y As Long
End Type
'Image的拷贝常量,用在Bitblt函数中
Private Const SRCCOPY = &HCC0020
'CombineRgn函数执行XOR操作的常数
Private Const RGN_XOR = 3
'文件的序号(全局变量)
Dim intF_Num As Integer
'移动窗体时记录下鼠标坐标(全局变量)
Dim xx As Single, yy As Single
'标识窗体是否可以移动(全局变量)
Dim blnMove As Boolean
'获取指定窗口的设备场景,HWnd为0时即屏幕的DC,
'在下面Bitblt函数中到用到屏幕的DC
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
'保存图片用到的关键函数,第一个参数用Picture Box的句柄,
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
'创建一个由点X1，Y1和X2，Y2描述的矩形区域
Private Declare Function CreateRectRgn Lib "gdi32" ( _
ByVal X1 As Long, _
ByVal Y1 As Long, _
ByVal X2 As Long, _
ByVal Y2 As Long) As Long
'将两个区域组合为一个新区域
Private Declare Function CombineRgn Lib "gdi32" ( _
ByVal hDestRgn As Long, _
ByVal hSrcRgn1 As Long, _
ByVal hSrcRgn2 As Long, _
ByVal nCombineMode As Long) As Long
'改变窗口的区域,中空的窗口就是用这个函数和上面两个函数组合生成的
Private Declare Function SetWindowRgn Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hRgn As Long, _
ByVal bRedraw As Long) As Long
'将用区坐标转换成屏幕坐标,用它来知道中空框的具体位置
Private Declare Function ClientToScreen Lib "user32" ( _
ByVal hwnd As Long, _
lpPoint As POINTAPI) As Long
'释放由调用GetDC或GetWindowDC函数获取的指定设备场景无效
'它对类或私有设备场景无效（但这样的调用不会造成损害）
'对那些用CreateDC一类的DC创建函数生成的设备场景，不要用本函数
Private Declare Function ReleaseDC Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hdc As Long) As Long
'取回与某一设备场景相关的窗口的句柄
Private Declare Function WindowFromDC Lib "user32" ( _
ByVal hdc As Long) As Long
'抓取图片
Private Sub Command1_Click()
Dim pos As POINTAPI
'下面两个值选取的是中空框在窗口的起始坐标
pos.X = 11: pos.Y = 12
'把刚选取的坐标转换成屏幕坐标,hwnd是Form1的句柄
ClientToScreen hwnd, pos
Dim lngDC As Long
'得到桌面的DC,用完后要释放
lngDC = GetDC(0)
'把"看到的"图片存在Picture1中
BitBlt Picture1.hdc, 0, 0, 128, 128, _
lngDC, pos.X, pos.Y, SRCCOPY
'更新Picture1,显示存进来的图片
Picture1.Refresh
'文件路径和文件名变量
Dim f_Path As String, f_name As String
'选当前路径为图片保存位置
f_Path = App.Path
If Right(f_Path, 1) <> "\" Then
f_Path = f_Path + "\"
End If
'记录文件编号
intF_Num = intF_Num + 1
'得到文件名
f_name = "pt" + Format(intF_Num, "000") + ".bmp"
'保存图片
SavePicture Picture1.Image, f_Path + f_name
ReleaseDC WindowFromDC(lngDC), lngDC '释放DC
End Sub
'改变窗口的颜色,目的是为存黑色背景的图片时看起来方便
Private Sub Command3_Click()
If Form1.BackColor = vbBlack Then
Frame1.BackColor = vbBlue
Form1.BackColor = vbBlue
Command3.BackColor = vbBlack
Else
Frame1.BackColor = vbBlack
Form1.BackColor = vbBlack
Command3.BackColor = vbBlue
End If
End Sub
'退出程序
Private Sub Command4_Click()
End
End Sub

Private Sub Form_Load()
'初始化文件编号
intF_Num = 0
'定位窗口显示在屏幕中间
With Me
.Top = (Screen.Height - .Height) / 2
.Left = (Screen.Width - .Width) / 2
End With
End Sub
'在本程序的窗口上"挖个洞"
Private Sub Form_Resize()
'"方洞"的句柄变量
Dim lngMyWhole As Long
'得到一个"矩形"的句柄
lngMyWhole = CreateRectRgn(0, 0, 0, 0)
'注意这句比较烦琐,lngMyWhole是这句执行的结果,其后的两个函数做为参数,
'第一个函数描述的是窗口的大小
'第二个函数描述的是要保存的图片的大小,注意数值的变化,35包含了窗口的标题栏高度
'把前两个函数返回的结果做为参数进行异或得到一个新区域
CombineRgn lngMyWhole, _
CreateRectRgn(0, 0, Me.Width, Me.Height), _
CreateRectRgn(15, 35, 143, 163), _
RGN_XOR
'"挖个洞",True是马上显示出来
SetWindowRgn hwnd, lngMyWhole, True
End Sub
'以下三个过程都是为了直观的移动窗口,因为Windows中移动窗口时是用虚框显示的
Private Sub Frame1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
'点下了鼠标就允许移动
xx = X: yy = Y: blnMove = True
End Sub

Private Sub Frame1_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If blnMove Then
If X < xx Then '左移
Form1.Left = Form1.Left - Int(xx - X)
Else '右移
Form1.Left = Form1.Left + Int(X - xx)
End If
If Y < yy Then '下移
Form1.Top = Form1.Top - Int(yy - Y)
Else '上移
Form1.Top = Form1.Top + Int(Y - yy)
End If
End If
End Sub

Private Sub Frame1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
'松开了鼠标就不允许移动
blnMove = False
End Sub