屏幕抓屏？？？

[wzxiaodu]

如何通过鼠标，选取一部分屏幕图像，在把它保存下来？？？

[fishmans]

可以这样，
用一个无边框窗体铺满整个屏幕并置顶，用bitblt函数把桌面抓成图片显示在这个窗体上
这样看起来就是把屏幕静止了
你用鼠标在这个窗体上画框取mousedown时的xy值与mouseup时的XY值
用窗体的paintpicture方法画到另一个不可见picturebox里再用savepicture方法保存就可以了
保存后记得把窗体卸掉

‘====================
注意，先抓图再全屏置顶

[孙小雄]

给你一个详细的例子

http://221.8.30.109/vb/zt.rar

[wzxiaodu]

sunxl(小呆) ，你的例子下载不了。。。。

[wzxiaodu]

fishmans(金脚指)，你的想法不错，
我试试，
不知还有其他方法吗？？？

[zyg0]

http://www.zg77hk.com/bbs/viewthread.php?tid=8773&fpage=1&highlight=%2Bzyg01234
我写的用控件实现的

[fishmans]

建一个DC，在DC上用鼠标画一个框。取出框的范围还是用bitblt
把桌面DC上的图贴到建的DC上，再保存DC上的图，这样可能实时一点。

[wzxiaodu]

我加了分了，高手，快来吧〉〉〉〉

[laviewpbt]

大家一起解决吧。

[wzxiaodu]

在“http://community.csdn.net/Expert/topic/4348/4348113.xml?temp=.9804956”
和我的问题是一样的

当中有 楼上（laviewpbt(人一定要靠自己)） 贴的程序，大家参考一下，
因为程序里有些问题，希望大家帮忙解决一下。。。。。

[laviewpbt]

Option Explicit

Private Const MOUSEEVENTF_LEFTDOWN As Long = &H2
Private Declare Function PtInRect Lib "user32" (lpRect As RECT, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData 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 SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) 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 GetDesktopWindow Lib "user32" () As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private 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 Long
End Type


Dim OriginalX As Single '区域起点X坐标
Dim OriginalY As Single '区域起点的Y坐标
Dim NewX As Single
Dim NewY As Single
Dim 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 Me
End 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 If
End 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 If
End 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 If
End Sub

[laviewpbt]

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 If
End Sub


Private Sub LblPos_Click()
SetCursorPos Shape1.Left + 1, Shape1.Top + 1
mouse_event MOUSEEVENTF_LEFTDOWN, 0, 0, 0, 0 '模拟左键按下
Call Form_DblClick
End 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 If
End Sub




' 释放内存空间
Private Sub Form_Unload(Cancel As Integer)
Set frmSnap = Nothing
End 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 Select
End 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, SourceDC
End Sub

[laviewpbt]

参考影子一起另外一个朋友的代码写的，感觉form_mousemove里面的代码太乱了。

[incubus]

试试

[zou19820704]

我不晓得，我帮你顶

[laviewpbt]

我用类似影子的方法也实现了，不过没有用哪个柯达控件，而是用shape和label组合实现。

[incubus]

效果还可以，如果可以象QQ那样在选择区域有八个点可以拖动 改变大小，就更好了。

[wzxiaodu]

这次能下载了，内容很好，谢谢大家！！！
！！！！！！！！！！！！！

[孙小雄]

http://221.8.30.109/vb/zt.rar
请再次下载