vb如何任意截屏

'模块中

Declare Function GetDC Lib "user32" (ByVal hwnd As Long) _

As Long

Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

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

'form1中

Private Sub Command1_Click()

Dim hDCtmp As Long, picWidth As Double, picHeight As Double

Dim x As Double

Dim y As Double

x = Val(Text2.Text)

y = Val(Text3.Text)

picWidth = Val(Text3.Text)

picHeight = Val(Text4.Text)

hDCtmp = GetDC(0)

BitBlt Picture1.hdc, 0, 0, picWidth, picHeight, hDCtmp, x, y, vbSrcCopy

ReleaseDC 0, hDCtmp

End Sub

目的: 将屏幕按照指定坐标和大小进行截取成图,在picture1显示

问题: 大小是相同了,为什么截取的坐标不对,只是屏幕上的左上

相信大家都用过QQ截图功能。不过很多人并没有真正掌握好它的用法。将QQ截图与其它截屏和制图软件配合使用，会有意想不到的效果。

获取颜色的RGB值

我们在编辑图片或网页的时候，经常需要获取某种颜色的“RGB值”，所以很多人都安装了第三方的颜色吸取工具。其时用QQ截图键即可获取屏幕上任意颜色的RGB值。

当按下“Ctrl+Shift+A”d出“截图”提示框时，提示框中的“当前像素RGB”即为当前鼠标屏幕位置的颜色RGB值，将鼠标移动到你想查看的屏幕颜色上即可获得相应的RGB值（如图1）。

图1精确截取图片大小

有时我们对要使用的截图尺寸有严格要求，比如论坛签名或QQ头像等。用QQ截图键可以按尺寸精确截取，一步到位无需再进行后期裁剪了。

按下QQ截图键，按住鼠标不放选取截取范围时，在鼠标上方会有一个信息框显示当前范围的详细信息，其中“矩形大小”就是以像素来表示的图片的尺寸大小，括号内的数字分别表示的是长和高（如图2）。松开鼠标调整截图框时，对照“矩形大小”就可以按需要的尺寸来精确截图范围，然后用鼠标点住截图框将截图框拖到要截取的图片上，双击即可获得所需尺寸的图片了。

图2图片拼贴好帮手

大部分的截图软件一次只能截取一张图片，当要截取多张图片并进行拼贴组合时，就需要一张一张截取全部保存后再进行拼贴 *** 作，非常麻烦。

我们知道用QQ截图键截取的图片可以在任一个可以粘贴图片的程序中使用，这样只需用截图软件进行一次截图 *** 作，剩下的图片用QQ截图键来截取，然后依次粘贴到截图软件的窗口中即可快速进行拼贴 *** 作了，是不是很方便啊。

小提示：QQ截图键无需打开聊天窗口即可使用，截取的图片在任一可粘贴图片的程序窗口中如画图、Word等，使用“粘贴”命令即可使用

1. 启动新 VisualBasic 常用 Exe 项目。 默认情况下创建 Form 1。

2. 在 项目 菜单上, 选择将一个新模块添加到现有项目 添加模块 。

3. 向窗体, 名称之一添加两 图片框 Pic_Edit （目标）, 和其他名称 Pic_Dest （目标）。

4. 将是 Pic_Edit Picture 属性设置为要从中选择区域位图

5. 将是 Pic_Dest AutoRedraw 属性设置为 True

6. 以下代码添加到 Module 1：Public Const INVERSE = 6

Public Const DOT = 2

Public Const SOLID = 0

Public OrigX As Long

Public OrigY As Long

Public DestX As Long

Public DestY As Long

Public Sub Draw_Selection_Rectangle()

' Set drawing mode to INVERSE since this routine also used to erase

' the selection rectangle by simply drawing over the currently

' displayed rectangle

With Editor.Pic_Edit

.DrawMode = INVERSE

.DrawStyle = DOT

Editor.Pic_Edit.Line (OrigX, OrigY)-(DestX, DestY), , B

.DrawStyle = SOLID

End With

End Sub

Public Sub Copy_Rectangle()

With Editor.Pic_Dest

.Cls

.Visible = True

.Height = DestY - OrigY

.Width = DestX - OrigX

.PaintPicture Editor.Pic_Edit, 0, 0, (DestX - OrigX), _

(DestY - OrigY), OrigX, OrigY, (DestX - OrigX), _

(DestY - OrigY), vbSrcCopy

End With

' Make sure the clipboard is clear, then copy the image:

Clipboard.Clear

Clipboard.SetData Editor.Pic_Dest.Image

End Sub

7. 以下代码添加到 Form 1：Private Sub Pic_Edit_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 1 Then Pic_Edit.Refresh

Pic_Dest.Visible = False

OrigX = X

OrigY = Y

DestX = OrigX

DestY = OrigY

Call Module1.Draw_Selection_Rectangle

End Sub

Private Sub Pic_Edit_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)

If Button = 1 Then

DestX = X

DestY = Y

Pic_Edit.Refresh

Call Module1.Draw_Selection_Rectangle

End If

End Sub

Private Sub Pic_Edit_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

' Check to see if mouse moved or goes the "wrong" way:

If DestX <= OrigX Or DestY <= OrigY Then

Pic_Edit.Refresh

Exit Sub

End If

If Button = 1 Then Call Copy_Rectangle

End Sub

8. 启动应用程序并选择用鼠标与位图的区域。 当您松开鼠标按钮, Pic_Dest 出现 备注 所选区域： 如果备份 MS 画图、 MSWord 或任何其他应用程序可能需要粘贴位图, 打开您就可以粘贴到该应用程序图像的选定部分。 也可以通过剪贴板查看程序查看剪贴板的内容。

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 GetDC Lib "user32" (ByVal hwnd As Long) As Long

'窗口上要放一个图片框和一个时钟控件。办法是把屏幕拷贝到图片框，再把图片框的Image保存到文件。

Private Sub Form_Load()

    If Dir("D:\截图", vbDirectory) = "" Then MkDir "D:\截图"

    Timer1.Enabled = False

    Timer1.Interval = 1000

    Picture1.Move 0, 0, Screen.Width, Screen.Height

    Picture1.AutoRedraw = True

    Picture1.Visible = False

End Sub

Private Sub Command1_Click()

    Me.WindowState = vbMinimized '开始后把窗口最小化，否则自己也会拷贝进去

    Timer1.Enabled = True

End Sub

Private Sub Timer1_Timer()

    Static imgIndex As Long

    imgIndex = imgIndex + 1

    BitBlt Picture1.hDC, 0, 0, Screen.Width \ Screen.TwipsPerPixelX, Screen.Height \ Screen.TwipsPerPixelY, GetDC(0), 0, 0, vbSrcCopy

    SavePicture Picture1.Image, "D:\截图\" & imgIndex & ".bmp"

End Sub

---