如何通过鼠标，选取一部分屏幕图像，在把它保存下来？？？_________________________________________________
可以这样，用一个无边框窗体铺满整个屏幕并置顶，用bitblt函数把桌面抓成图片显示在这个窗体上这样看起来就是把屏幕静止了你用鼠标在这个窗体上画框取mousedown时的xy值与mouseup时的XY值用窗体的paintpicture方法画到另一个不可见picturebox里再用savepicture方法保存就可以了保存后记得把窗体卸掉
‘====================注意，先抓图再全屏置顶
http://www.zg77hk.com/bbs/viewthread.php?tid=8773&fpage=1&highlight=+zyg01234我写的用控件实现的_____________________________________________________________________
我用类似影子的方法也实现了，不过没有用哪个柯达控件，而是用shape和label组合实现。Option Explicit
Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As LongPrivate Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Long) As LongPrivate Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As LongPrivate Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As LongPrivate Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As LongPrivate 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 LongPrivate Declare Function GetDesktopWindow Lib "user32" () As LongPrivate Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As LongPrivate Declare Function EmptyClipboard Lib "user32" () As LongPrivate Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As LongPrivate Declare Function CloseClipboard Lib "user32" () As LongPrivate Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As LongPrivate Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As LongPrivate Declare Sub mouse_event Lib "user32" (ByVal dwFlags As Long, ByVal dx As Long, ByVal dy As Long, ByVal cButtons As Long, ByVal dwExtraInfo As Long)Private Declare Function SetCursorPos Lib "user32" (ByVal x As Long, ByVal y As Long) As Long
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 LongEnd Type
Dim OriginalX As Single '区域起点X坐标Dim OriginalY As Single '区域起点的Y坐标Dim NewX As SingleDim NewY As SingleDim Status As String '当前状态（正在选择区域或者拖动区域）Dim rc As RECT '区域的范围Dim ptInPic As Boolean '鼠标是否位于pic上
Private Sub Form_Load() Dim SourceDC As Long AutoRedraw = True Me.WindowState = 2 Screen.MousePointer = vbCrosshair ' 将光标改为十字型 SourceDC = CreateDC("DISPLAY", 0, 0, 0) BitBlt Me.hdc, 0, 0, Screen.Width / 15, Screen.Height / 15, SourceDC, 0, 0, &HCC0020 '拷贝当前桌面到窗体 Status = "draw" '绘图状态 SetTitle 1 '设置提示的内容End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)If KeyAscii = vbKeyEscape Then Unload MeEnd Sub
Private Sub Form_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Status = "draw" Then '如果是抓取状态 Shape1.Visible = True Shape1.Width = 0 Shape1.Height = 0 OriginalX = x OriginalY = y '起点坐标 Shape1.Left = OriginalX Shape1.Top = OriginalY Call SetTitle(1) Else '移动状态 rc.Left = Shape1.Left rc.Right = Shape1.Left + Shape1.Width rc.Top = Shape1.Top rc.Bottom = Shape1.Top + Shape1.Height If PtInRect(rc, x, y) Then '如果按下的点位于区域内 NewX = x NewY = y '则移动区域 Else '否则重新画一个区域 Shape1.Width = 0 Shape1.Height = 0 OriginalX = x OriginalY = y Shape1.Left = OriginalX Shape1.Top = OriginalY Status = "draw" '状态恢复到抓取 Call SetTitle(2) End If End IfEnd Sub
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) Dim Info As String If Button = 1 Then Shape1.Visible = False LblPos.Visible = False If Status = "draw" Then '如果是绘图状态 If x > OriginalX And y > OriginalY Then '根据鼠标位置调整shape1的大小和位置 Shape1.Move OriginalX, OriginalY, x - OriginalX, y - OriginalY ElseIf x < OriginalX And y > OriginalY Then Shape1.Move x, OriginalY, OriginalX - x, y - OriginalY ElseIf x > OriginalX And y < OriginalY Then Shape1.Move OriginalX, y, x - OriginalX, OriginalY - y ElseIf x < OriginalX And y < OriginalY Then Shape1.Move x, y, OriginalX - x, OriginalY - y End If Info = Shape1.Width & "x" & Shape1.Height '显示当前区域的大小 LblPos.Move Shape1.Left + Shape1.Width / 2 - TextWidth(Info) / 2, Shape1.Top + Shape1.Height / 2 - TextHeight(Info) / 2 LblPos.Caption = Info Screen.MousePointer = vbCrosshair Else '如果是移动状态 Screen.MousePointer = 5 Shape1.Left = OriginalX - (NewX - x) Shape1.Top = OriginalY - (NewY - y) If Shape1.Left < 0 Then Shape1.Left = 0 '使区域不超过屏幕 If Shape1.Top < 0 Then Shape1.Top = 0 If Shape1.Left + Shape1.Width > Screen.Width / 15 Then Shape1.Left = Screen.Width / 15 - Shape1.Width If Shape1.Top + Shape1.Height > Screen.Height / 15 Then Shape1.Top = Screen.Height / 15 - Shape1.Height LblPos.Move Shape1.Left + Shape1.Width / 2 - TextWidth(LblPos.Caption) / 2, Shape1.Top + Shape1.Height / 2 - TextHeight(LblPos.Caption) / 2 End If Shape1.Visible = True LblPos.Visible = True End IfEnd Sub
Private Sub Form_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 1 Then Call SetTitle(3) If Status = "draw" Then Status = "move" End If OriginalX = Shape1.Left '更新OriginalX，因为选择区域时可能会出现shape的right点大于left点 OriginalY = Shape1.Top Else Unload Me '右键退出 End IfEnd Sub
Private Sub Form_DblClick() '双击拷贝区域图象到剪贴板 If PtInRect(rc, NewX, NewY) Then '看是否在区域内 Picture1.Visible = False DoEvents ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height Unload Me End IfEnd Sub
Private Sub LblPos_Click() SetCursorPos Shape1.Left + 1, Shape1.Top + 1 mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 '模拟左键按下 Call Form_DblClickEnd Sub
Private Sub Picture1_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single) If ptInPic = 1 Or Picture1.Left = Me.ScaleLeft Then '改变提示框的位置 With Picture1 .Move Me.ScaleWidth - .Width, .Top, .Width, .Height End With ptInPic = 2 Else ptInPic = 1 With Picture1 .Move Me.ScaleLeft, .Top, .Width, .Height End With End IfEnd Sub
' 释放内存空间Private Sub Form_Unload(Cancel As Integer) Set frmSnap = NothingEnd Sub
Public Sub SetTitle(index As Integer) Select Case index Case 1 lblInfo(0).Caption = "* 按住鼠标左键不放选择" & vbCrLf & " 截图的范围." lblInfo(1).Caption = "* 按ESC键退出." lblInfo(2).Caption = "" Case 2 lblInfo(0).Caption = "* 松开鼠标左键确定截图" & vbCrLf & " 的范围." lblInfo(1).Caption = "* 按ESC键退出." lblInfo(2).Caption = "" Case 3 lblInfo(0).Caption = "* 用鼠标左键调整截图的" & vbCrLf & " 位置." lblInfo(1).Caption = "* 双击选取区域保存图片." lblInfo(2).Caption = "* 按ESC键退出." End SelectEnd Sub
' 拷贝选定方框区域的屏幕图像到剪贴板Public Sub ScrnCap(Left As Long, Top As Long, Right As Long, Bottom As Long) Shape1.Visible = False '不需要拷贝shape LblPos.Visible = False DoEvents Dim rWidth As Long Dim rHeight As Long Dim SourceDC As Long Dim DestDC As Long Dim BHandle As Long Dim Wnd As Long Dim DHandle As Long rWidth = Right - Left rHeight = Bottom - Top SourceDC = CreateDC("DISPLAY", 0, 0, 0) DestDC = CreateCompatibleDC(SourceDC) BHandle = CreateCompatibleBitmap(SourceDC, rWidth, rHeight) SelectObject DestDC, BHandle BitBlt DestDC, 0, 0, rWidth, rHeight, SourceDC, Left, Top, &HCC0020 Wnd = GetDesktopWindow OpenClipboard Wnd EmptyClipboard SetClipboardData 2, BHandle CloseClipboard DeleteDC DestDC ReleaseDC DHandle, SourceDCEnd Sub
http://221.8.30.109/vb/zt.rar请再次下载
