第一次在vb块提问，100分求弄通屏幕截图代码

[tiantian1980]

第一次在vb块提问，100分求弄通以下屏幕截图代码，看懂了大概。但用VB6.0调试有错误，总是VB遇到问题要关闭也不报错。运行原码如下：
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 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, ByVal Cy As Long, ByVal wFlags 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 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 Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Sub GetRGBColors(ByVal RGBColor As Long, ByRef RedColor As Long, ByRef GreenColor As Long, ByRef BlueColor As Long)
RedColor = RGBColor Mod 256
GreenColor = (RGBColor \ &H100) Mod 256
BlueColor = (RGBColor \ &H10000) Mod 256
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

Private Sub Form_Load()
Picture1.Top = -Picture1.Height
Picture1.Visible = True
Dim SourceDC As Long
Me.AutoRedraw = True
Me.ScaleMode = 3
Screen.MousePointer = vbCrosshair ' 将光标改为十字型
SourceDC = CreateDC("DISPLAY ", 0, 0, 0)
BitBlt Me.hdc, 0, 0, Screen.Width / 15, Screen.Height / 15, SourceDC, 0, 0, &HCC0020 '拷贝当前屏幕到窗体
DeleteDC SourceDC
Me.WindowState = 2
Status = "draw " '绘图状态
SetTitle 1 '设置提示的内容
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
Unload Me
End If
End Sub

Private Sub Timer1_Timer()
Picture1.Top = Picture1.Top + 4 '模拟QQ截屏时的左上角的提示图片的效果
If Picture1.Top > 0 Then
Timer1.Enabled = False
End If
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_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
End If
End Sub

[tiantian1980]

第一次在vb块提问，100分求弄通以下屏幕截图代码，看懂了大概。但用VB6.0调试有错误，总是VB遇到问题要关闭也不报错。运行原码如下：
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 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 GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal Cx As Long, ByVal Cy As Long, ByVal wFlags 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 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 Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)

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 Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Sub GetRGBColors(ByVal RGBColor As Long, ByRef RedColor As Long, ByRef GreenColor As Long, ByRef BlueColor As Long)
RedColor = RGBColor Mod 256
GreenColor = (RGBColor \ &H100) Mod 256
BlueColor = (RGBColor \ &H10000) Mod 256
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

Private Sub Form_Load()
Picture1.Top = -Picture1.Height
Picture1.Visible = True
Dim SourceDC As Long
Me.AutoRedraw = True
Me.ScaleMode = 3
Screen.MousePointer = vbCrosshair ' 将光标改为十字型
SourceDC = CreateDC("DISPLAY ", 0, 0, 0)
BitBlt Me.hdc, 0, 0, Screen.Width / 15, Screen.Height / 15, SourceDC, 0, 0, &HCC0020 '拷贝当前屏幕到窗体
DeleteDC SourceDC
Me.WindowState = 2
Status = "draw " '绘图状态
SetTitle 1 '设置提示的内容
End Sub

Private Sub Form_KeyPress(KeyAscii As Integer)
If KeyAscii = vbKeyEscape Then
Unload Me
End If
End Sub

Private Sub Timer1_Timer()
Picture1.Top = Picture1.Top + 4 '模拟QQ截屏时的左上角的提示图片的效果
If Picture1.Top > 0 Then
Timer1.Enabled = False
End If
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_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
End If
End Sub

[tiantian1980]

续－－－－
Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblInfo(3).Visible = False
Dim RGBColor As Long, Red As Long, Green As Long, Blue As Long
RGBColor = GetPixel(Me.hdc, X, Y)
GetRGBColors RGBColor, Red, Green, Blue
lblInfo(3).Caption = "( " & Red & ", " & Green & ", " & Blue & ") "
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
lblInfo(3).Visible = True
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_DblClick()
If PtInRect(rc, NewX, NewY) Then '看是否在区域内
Picture1.Visible = False '如果选区包含部分提示图片，则需要把图片先隐藏。
Sleep 10 '有时候没有这两句会使得shape1也显示在截取的区域里
DoEvents
Shape1.Visible = False
ScrnCap Shape1.Left, Shape1.Top, Shape1.Left + Shape1.Width, Shape1.Top + Shape1.Height
MsgBox "图象已经保存到剪贴板中 ", vbInformation, "提示 "
Unload Me
End If
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

[cbm6666]

看晕了.......

不就是在屏幕上以鼠标按下弹起, 将这区块的图片存图吗? 我以前做了一个只是测试用, 并没像QQ使用Ctrl+Alt+A热键以及菜单方式, 我就是以mousemove mousrdown mouseup 抓图,Command按钮保存而已,效果没问题, 但代码长度是你的1/3不到吧, 看你那代码不是说不好,而是太杂了,要看懂要纠错,上帝看了也疯狂.

要做到像QQ那样,用我这代码再改一下, 也不是难事, 你要的话就给我邮箱吧, 我不要你的分,用来问其它问题吧.

[tiantian1980]

[e-mail]

[tiantian1980]

其实代码也不是很多，第1回复发重了

[cbm6666]

已发给你啦, 我的代码你看不懂那才怪, 呵呵.

[zskllj]

把
SourceDC = CreateDC("DISPLAY ", 0, 0, 0) 这句改成
SourceDC = CreateDC("DISPLAY", vbNullString, vbNullString, 0)

[tiantian1980]

楼上的，我先前就改过的，但是还是不通！

[智能卡_Snooper]

应该把整个form的内容全发上来，光发代码太费劲。

[熊孩子开学喽]

只是抓屏幕图片
拿我以前的代码出来，改一下调用就可以了：
http://blog.csdn.net/wallescai/archive/2004/12/31/235270.aspx

本来是这样调用：
DibGet Picture1.hdc, 0, 0, Picture1.Width - 1, Picture1.Height - 1
改成：
Dibget GetDC(GetDesktopWindow), rc.LEFT, rc,TOP, rc.RIGHT, rc.Bottom

就这样，没了。

[嗷嗷叫的老马]

................路过

[tiantian1980]

谢谢楼上的几位，我把它调试通了

[dodo07coco]

wo正在做着方面，能不能把你调好的代码发给我，谢谢[e-mail]