用VB6屏幕截图

用VB6.0实现，本人vb比较菜，所以最好是完整代码，也希望能附上注释，在这里多谢了~

问题补充：

借助外部工具比较简单，我想用代码实现 ，希望高手帮一下，非常感谢！！

辛语辛辰 ，savepicture可以保存图片，不过我想保存时主窗体中的一部分，并且上面可能有控件，不知道还有什么方法吗？

最佳答案

Dim t As Boolean

Dim f As Boolean

Private Sub Form_Load()

= 100

= 100

draw = True

End Sub

Private Sub Pic0_MouseMove(Button As Integer, Shift As Integer, X As Single,

Y As Single)

If t = False Then

= X

= Y

End If

If Button = 1 And f = False Then

t = True

= X -

= Y -

icture e, 0, 0, , , , , ,

End If

End Sub

Private Sub Pic0_MouseUp(Button As Integer, Shift As Integer, X As Single, Y

As Single)

If Button = 1 Then f = True

e =

If Button = 2 Then

t = False

f = False

= 100

= 100

End If

End Sub

注释不用了吧，用SavePicture 语句保存图片

说详细点，它截取的是背景

vb 屏幕区域截图

悬赏分：0 |

解决时间：2008-3-8 19:24 |

提问者：開始習慣孤單

例如我要截下屏幕上728,292,766,305处的图并保存,怎样写代码

代码越短越好

最佳答案

Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc 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

nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As

Long

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

Const Srccopy = &HCC0020

Private Sub Picture1_Click()

StretchBlt , 0, 0, 766 - 728, 305 - 292, GetDC(0), 728, 292, 766 -

728, 305 - 292,Srccopy

'自己写保存图片的过程吧~

End Sub

PictureBox的ScaleMode要设置为pixel.

你试试这个行不~

PS 这个问题我好像见过 ?_?

通过VB的BitBlt API来实现 窗口局部区域截图

悬赏分：150 |

解决时间：2010-10-21 22:52 |

提问者：诚信欢迎你

我想将这个代码写成一个函数形式，保存为DLL文件

自己用SavePicture方法可以保存图片但是，保存为DLL的时候报错说未定义什么

我想各位帮忙想想通过什么方法能保存为图片

问题补充：

此问题通过交换方法已经解决了，3楼给的方法就是我说的那方法不过用到了插件

故无法生成DLL吧，不过还是非常感谢

最佳答案

这个问题我以前也弄过，后来卡在你这个问题同样的地方没弄下去，现在看到你的问题，很有感触，准备再弄一下看看，没想到成功了哈，下面是代码，实现了后台截图并且保存，可以用到一些游戏脚本里面哈。

首席准备2个Picture窗口和一个按钮，然后就是下面的代码，有问题请补充问题，我们交流哈哈

Option Explicit

Private Declare Function PrintWindow Lib "user32" (ByVal hWnd As Long,

ByVal hdcBlt As Long, ByVal nFlags 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 Sub Command1_Click()

Dim a

a = PrintWindow(395116, , 0)

BitBlt , 0, 0, 300, 300, , 0, 0, vbSrcCopy

SavePicture , "c:"

End Sub

注意，2个Picture窗口的AutoRedraw属性必须设置成真

第一个Picture后台获取整张图片，第二个用来获取需要的大小

模拟QQ截屏效果。 收藏

QQ确实太占资源了， 物理内存和虚拟内存加起来大概有40多M，不过他提供的屏幕截图功能却是不错，能方便的选取能所感兴趣的区域图片，本文试图用VB模拟这一功能，当然功能还是要比QQ截屏少一点，但基本的功能以完备。

截屏原理：QQ截屏应该时先把当前屏幕的内容拷贝到一个窗体，并且这个窗体和屏幕一样大，然后再对这个窗体上的图片进行处理，因此在使用QQ截屏的时候你会发现托盘区那个网络链接的图标不会有变换，把鼠标放在时间上也不会有日期提示了。

知道了原理，用VB来实现也不时一件难事了。

窗体及倥件设置：一个picturebox，picture属性设置为你自己想要的图片（既然模仿QQ，就用他截屏时出现再屏幕顶部那个图片吧），其上有几个label倥件数组(lblInfo(0~4))，

用来显示提示信息的。一个Timer倥件，interal设置为20，用来模拟QQ截屏时提示图片的下拉效果。一个shape倥件,形状为矩形，边框样式为虚线点装。设置窗体的borderstyle为无边框的，showintaskbar属性为true(一定要为True).，keypreview属性为true.

下面是代码：

'程序实现功能：模拟QQ截屏

'作 者： laviewpbt

'联系方式： laviewpbt@

'QQ:33184777

'版本：Version 1.0.0

'说明：复制请保留源作者信息，转载请说明，欢迎大家提出意见和建议

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

'*************************************************************************

'** 作 者 ： 未知

'** 函 数 名 ： GetRGBColors

'** 输 入 ： 省

'** 输 出 ： 无

'** 功能描述 ： 得到RGB值

'** 日 期 ： 2005-10-24 20.10.56

'** 修 改 人 ： laviewpbt

'** 日 期 ： 2005-10-24 20.11.23

'** 版 本 ： Version 1.2.1

'*************************************************************************

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

'*************************************************************************

'** 作 者 ： laviewpbt

'** 函 数 名 ： EDcode

'** 输 入 ： index(Integer) - 提示编码

'** 输 出 ： 无

'** 功能描述 ： 改变提示信息

'** 日 期 ： 2005-10-26 17.49.54

'** 修 改 人 ：

'** 日 期 ：

'** 版 本 ： Version 1.2.1

'*************************************************************************

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()

= -

e = True

Dim SourceDC As Long

draw = True

ode = 3

ointer = vbCrosshair ' 将光标改为十字型

SourceDC = CreateDC("DISPLAY", 0, 0, 0)

BitBlt , 0, 0, / 15, / 15, SourceDC, 0, 0, &HCC0020

'拷贝当前屏幕到窗体

DeleteDC SourceDC

State = 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()

= + 4 '模拟QQ截屏时的左上角的提示图片的效果

If > 0 Then

d = 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 '如果是抓取状态

e = True

= 0

= 0

OriginalX = X

OriginalY = Y '起点坐标

= OriginalX

= OriginalY

Call SetTitle(1)

Else '如果鼠标点在画好的选区内，则移动画好的选区

=

= +

=

= +

If PtInRect(rc, X, Y) Then '如果按下的点位于区域内

NewX = X

NewY = Y '则移动区域

Else '否则重新画一个区域

= 0

= 0

OriginalX = X

OriginalY = Y

= OriginalX

= 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 = '更新OriginalX，因为选择区域时可能会出现shape

的right点大于left点

OriginalY =

End If

End Sub

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(, X, Y)

GetRGBColors RGBColor, Red, Green, Blue

lblInfo(3).Caption = "(" & Red & "," & Green & "," & Blue & ")"

Dim Info As String

If Button = 1 Then

e = False

e = False

If Status = "draw" Then '如果是绘图状态

If X > OriginalX And Y > OriginalY Then '根据鼠标位置调整shape1的大小和位置

OriginalX, OriginalY, X - OriginalX, Y - OriginalY

ElseIf X < OriginalX And Y > OriginalY Then

X, OriginalY, OriginalX - X, Y - OriginalY

ElseIf X > OriginalX And Y < OriginalY Then

OriginalX, Y, X - OriginalX, OriginalY - Y

ElseIf X < OriginalX And Y < OriginalY Then

X, Y, OriginalX - X, OriginalY - Y

End If

Info = & "x" & '显示当前区域的大小

+ / 2 - TextWidth(Info) / 2, +

/ 2 - TextHeight(Info) / 2

n = Info

ointer = vbCrosshair

Else '如果是移动状态

ointer = 5

= OriginalX - (NewX - X)

= OriginalY - (NewY - Y)

If < 0 Then = 0 '使区域不超过屏幕

If < 0 Then = 0

If + > / 15 Then =

/ 15 -

If + > / 15 Then =

/ 15 -

+ / 2 - TextWidth(n) / 2,

+ / 2 - TextHeight(n) / 2

End If

e = True

e = 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 = eft Then '改变提示框的位置

With Picture1

.Move idth - .Width, .Top, .Width, .Height

End With

ptInPic = 2

Else

ptInPic = 1

With Picture1

.Move eft, .Top, .Width, .Height

End With

End If

End Sub

Private Sub Form_DblClick()

If PtInRect(rc, NewX, NewY) Then '看是否在区域内

e = False '如果选区包含部分提示图片，则需要把图片先隐藏。

Sleep 10 '有时候没有这两句会使得shape1也显示在截取的区域里

DoEvents

e = False

ScrnCap , , + , +

MsgBox "图象已经保存到剪贴板中", vbInformation, "提示"

Unload Me

End If

End Sub

'*************************************************************************

'** 作 者 ： laviewpbt

'** 函 数 名 ： EDcode

'** 输 入 ： Left(Long) - 左起点

'** 输 入 ： Top(Long) - 顶点

'** 输 入 ： Right(Long) - 右边界

'** 输 入 ： Bottom(Long) - 下边界

'** 输 出 ： 无

'** 功能描述 ： 拷贝选定方框区域的屏幕图像到剪贴板

'** 日 期 ： 2005-10-26 17.49.23

'** 修 改 人 ：

'** 日 期 ：

'** 版 本 ： Version 1.2.1

'*************************************************************************

Public Sub ScrnCap(Left As Long, Top As Long, Right As Long, Bottom As Long)

e = False '不需要拷贝shape

e = 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

效果图：

如果在你的程序中，你想在某种情况下调用截屏功能，稍微改下就可以了，我想对大家没有什么难度的。

当然代码没有QQ的那个八个角度拖动选择区域的功能。

希望大家多提建议和意见!!!

本文来自CSDN博客，转载请/laviewpbt/archive/2006/11/07/

标明出处：VB怎么从picture1中截取指定坐标的区域图像到picture2中

悬赏分：0 |

解决时间：2010-4-15 11:21 |

提问者：ikmusic

请给个指定坐标X,Y截取图像的范例程序

最佳答案

'添加两个图片框控件Picture1和Picture2

'再添加一个Command1按钮。

Option Explicit

Private Sub Command1_Click()

Dim StartX, EndX

Dim StartY, EndY

StartX = 90

StartY = 0

EndX = 210

EndY = 100

With Picture2

.Cls

.PaintPicture e, 0, 0, EndX - StartX, EndY - StartY, _

StartX, StartY, EndX - StartX, EndY - StartY

End With

End Sub

Private Sub Form_Load()

draw = True

ode = ls

e = LoadPicture("C:")

End Sub