用VB6屏幕截图.docx
- 文档编号:2390962
- 上传时间:2023-05-03
- 格式:DOCX
- 页数:18
- 大小:33.73KB
用VB6屏幕截图.docx
《用VB6屏幕截图.docx》由会员分享,可在线阅读,更多相关《用VB6屏幕截图.docx(18页珍藏版)》请在冰点文库上搜索。
用VB6屏幕截图
用VB6.0实现,本人vb比较菜,所以最好是完整代码,也希望能附上注释,在这里多谢了~
问题补充:
借助外部工具比较简单,我想用代码实现,希望高手帮一下,非常感谢!
!
辛语辛辰,savepicture可以保存图片,不过我想保存时主窗体中的一部分,并且上面可能有控件,不知道还有什么方法吗?
最佳答案
DimtAsBoolean
DimfAsBoolean
PrivateSubForm_Load()
Pic.Height=100
Pic.Width=100
Pic.AutoRedraw=True
EndSub
PrivateSubPic0_MouseMove(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
Ift=FalseThen
Pic.Left=X
Pic.Top=Y
EndIf
IfButton=1Andf=FalseThen
t=True
Pic.Width=X-Pic.Left
Pic.Height=Y-Pic.Top
Pic.PaintPicturePic0.Picture,0,0,,,Pic.Left,Pic.Top,Pic.Width,Pic.Height
EndIf
EndSub
PrivateSubPic0_MouseUp(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
IfButton=1Thenf=True
Pic2.Picture=Pic.Image
IfButton=2Then
t=False
f=False
Pic.Width=100
Pic.Height=100
EndIf
EndSub
注释不用了吧,用SavePicture语句保存图片
说详细点,它截取的是背景
vb屏幕区域截图
悬赏分:
0|解决时间:
2008-3-819:
24|提问者:
開始習慣孤單
例如我要截下屏幕上728,292,766,305处的图并保存,怎样写代码
代码越短越好
最佳答案
PrivateDeclareFunctionStretchBltLib"gdi32"(ByValhdcAsLong,ByValxAsLong,ByValyAsLong,ByValnWidthAsLong,ByValnHeightAsLong,ByValhSrcDCAsLong,ByValxSrcAsLong,ByValySrcAsLong,ByValnSrcWidthAsLong,ByValnSrcHeightAsLong,ByValdwRopAsLong)AsLong
PrivateDeclareFunctionGetDCLib"user32"(ByValhwndAsLong)AsLong
ConstSrccopy=&HCC0020
PrivateSubPicture1_Click()
StretchBltPicture1.hdc,0,0,766-728,305-292,GetDC(0),728,292,766-728,305-292,Srccopy
'自己写保存图片的过程吧~
EndSub
PictureBox的ScaleMode要设置为pixel.
你试试这个行不~
PS这个问题我好像见过?
_?
通过VB的BitBltAPI来实现窗口局部区域截图
悬赏分:
150|解决时间:
2010-10-2122:
52|提问者:
诚信欢迎你
我想将这个代码写成一个函数形式,保存为DLL文件
自己用SavePicture方法可以保存图片但是,保存为DLL的时候报错说未定义什么
我想各位帮忙想想通过什么方法能保存为图片
问题补充:
此问题通过交换方法已经解决了,3楼给的方法就是我说的那方法不过用到了插件
故无法生成DLL吧,不过还是非常感谢
最佳答案
这个问题我以前也弄过,后来卡在你这个问题同样的地方没弄下去,现在看到你的问题,很有感触,准备再弄一下看看,没想到成功了哈,下面是代码,实现了后台截图并且保存,可以用到一些游戏脚本里面哈。
首席准备2个Picture窗口和一个按钮,然后就是下面的代码,有问题请补充问题,我们交流哈哈
OptionExplicit
PrivateDeclareFunctionPrintWindowLib"user32"(ByValhWndAsLong,ByValhdcBltAsLong,ByValnFlagsAsLong)AsLong
PrivateDeclareFunctionBitBltLib"gdi32"(ByValhDestDCAsLong,ByValxAsLong,ByValyAsLong,ByValnWidthAsLong,ByValnHeightAsLong,ByValhSrcDCAsLong,ByValxSrcAsLong,ByValySrcAsLong,ByValdwRopAsLong)AsLong
PrivateSubCommand1_Click()
Dima
a=PrintWindow(395116,Picture1.hDC,0)
BitBltPicture2.hDC,0,0,300,300,Picture1.hDC,0,0,vbSrcCopy
SavePicturePicture2.Image,"c:
\aaa.bmp"
EndSub
注意,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
'版本:
Version1.0.0
'说明:
复制请保留源作者信息,转载请说明,欢迎大家提出意见和建议
PrivateDeclareFunctionPtInRectLib"user32"(lpRectAsRECT,ByValXAsLong,ByValYAsLong)AsLong
PrivateDeclareFunctionCreateDCLib"gdi32"Alias"CreateDCA"(ByVallpDriverNameAsString,ByVallpDeviceNameAsString,ByVallpOutputAsString,lpInitDataAsLong)AsLong
PrivateDeclareFunctionBitBltLib"gdi32"(ByValhDestDCAsLong,ByValXAsLong,ByValYAsLong,ByValnWidthAsLong,ByValnHeightAsLong,ByValhSrcDCAsLong,ByValxSrcAsLong,ByValySrcAsLong,ByValdwRopAsLong)AsLong
PrivateDeclareFunctionGetPixelLib"gdi32"(ByValhdcAsLong,ByValXAsLong,ByValYAsLong)AsLong
PrivateDeclareFunctionSetWindowPosLib"user32"(ByValhwndAsLong,ByValhWndInsertAfterAsLong,ByValXAsLong,ByValYAsLong,ByValCxAsLong,ByValCyAsLong,ByValwFlagsAsLong)AsLong
PrivateDeclareFunctionCreateCompatibleDCLib"gdi32"(ByValhdcAsLong)AsLong
PrivateDeclareFunctionCreateCompatibleBitmapLib"gdi32"(ByValhdcAsLong,ByValnWidthAsLong,ByValnHeightAsLong)AsLong
PrivateDeclareFunctionSelectObjectLib"gdi32"(ByValhdcAsLong,ByValhObjectAsLong)AsLong
PrivateDeclareFunctionGetDesktopWindowLib"user32"()AsLong
PrivateDeclareFunctionOpenClipboardLib"user32"(ByValhwndAsLong)AsLong
PrivateDeclareFunctionEmptyClipboardLib"user32"()AsLong
PrivateDeclareFunctionSetClipboardDataLib"user32"(ByValwFormatAsLong,ByValhMemAsLong)AsLong
PrivateDeclareFunctionCloseClipboardLib"user32"()AsLong
PrivateDeclareFunctionDeleteDCLib"gdi32"(ByValhdcAsLong)AsLong
PrivateDeclareFunctionReleaseDCLib"user32"(ByValhwndAsLong,ByValhdcAsLong)AsLong
PrivateDeclareSubSleepLib"kernel32"(ByValdwMillisecondsAsLong)
DimOriginalXAsSingle'区域起点X坐标
DimOriginalYAsSingle'区域起点的Y坐标
DimNewXAsSingle
DimNewYAsSingle
DimStatusAsString'当前状态(正在选择区域或者拖动区域)
DimrcAsRECT'区域的范围
DimptInPicAsBoolean'鼠标是否位于pic上
PrivateTypeRECT
LeftAsLong
TopAsLong
RightAsLong
BottomAsLong
EndType
'*************************************************************************
'**作者:
未知
'**函数名:
GetRGBColors
'**输入:
省
'**输出:
无
'**功能描述:
得到RGB值
'**日期:
2005-10-2420.10.56
'**修改人:
laviewpbt
'**日期:
2005-10-2420.11.23
'**版本:
Version1.2.1
'*************************************************************************
PrivateSubGetRGBColors(ByValRGBColorAsLong,ByRefRedColorAsLong,ByRefGreenColorAsLong,ByRefBlueColorAsLong)
RedColor=RGBColorMod256
GreenColor=(RGBColor\&H100)Mod256
BlueColor=(RGBColor\&H10000)Mod256
EndSub
'*************************************************************************
'**作者:
laviewpbt
'**函数名:
EDcode
'**输入:
index(Integer)-提示编码
'**输出:
无
'**功能描述:
改变提示信息
'**日期:
2005-10-2617.49.54
'**修改人:
'**日期:
'**版本:
Version1.2.1
'*************************************************************************
PublicSubSetTitle(IndexAsInteger)
SelectCaseIndex
Case1
lblInfo(0).Caption="*按住鼠标左键不放选择"&vbCrLf&"截图的范围."
lblInfo
(1).Caption="*按ESC键退出."
lblInfo
(2).Caption=""
Case2
lblInfo(0).Caption="*松开鼠标左键确定截图"&vbCrLf&"的范围."
lblInfo
(1).Caption="*按ESC键退出."
lblInfo
(2).Caption=""
Case3
lblInfo(0).Caption="*用鼠标左键调整截图的"&vbCrLf&"位置."
lblInfo
(1).Caption="*双击选取区域保存图片."
lblInfo
(2).Caption="*按ESC键退出."
EndSelect
EndSub
PrivateSubForm_Load()
Picture1.Top=-Picture1.Height
Picture1.Visible=True
DimSourceDCAsLong
Me.AutoRedraw=True
Me.ScaleMode=3
Screen.MousePointer=vbCrosshair'将光标改为十字型
SourceDC=CreateDC("DISPLAY",0,0,0)
BitBltMe.hdc,0,0,Screen.Width/15,Screen.Height/15,SourceDC,0,0,&HCC0020'拷贝当前屏幕到窗体
DeleteDCSourceDC
Me.WindowState=2
Status="draw"'绘图状态
SetTitle1'设置提示的内容
EndSub
PrivateSubForm_KeyPress(KeyAsciiAsInteger)
IfKeyAscii=vbKeyEscapeThen
UnloadMe
EndIf
EndSub
PrivateSubTimer1_Timer()
Picture1.Top=Picture1.Top+4'模拟QQ截屏时的左上角的提示图片的效果
IfPicture1.Top>0Then
Timer1.Enabled=False
EndIf
EndSub
PrivateSubForm_MouseDown(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
IfStatus="draw"Then'如果是抓取状态
Shape1.Visible=True
Shape1.Width=0
Shape1.Height=0
OriginalX=X
OriginalY=Y'起点坐标
Shape1.Left=OriginalX
Shape1.Top=OriginalY
CallSetTitle
(1)
Else'如果鼠标点在画好的选区内,则移动画好的选区
rc.Left=Shape1.Left
rc.Right=Shape1.Left+Shape1.Width
rc.Top=Shape1.Top
rc.Bottom=Shape1.Top+Shape1.Height
IfPtInRect(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"'状态恢复到抓取
CallSetTitle
(2)
EndIf
EndIf
EndSub
PrivateSubForm_MouseUp(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
IfButton=1Then
CallSetTitle(3)
IfStatus="draw"Then
Status="move"
EndIf
OriginalX=Shape1.Left'更新OriginalX,因为选择区域时可能会出现shape的right点大于left点
OriginalY=Shape1.Top
EndIf
EndSub
PrivateSubForm_MouseMove(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
lblInfo(3).Visible=False
DimRGBColorAsLong,RedAsLong,GreenAsLong,BlueAsLong
RGBColor=GetPixel(Me.hdc,X,Y)
GetRGBColorsRGBColor,Red,Green,Blue
lblInfo(3).Caption="("&Red&","&Green&","&Blue&")"
DimInfoAsString
IfButton=1Then
Shape1.Visible=False
LblPos.Visible=False
IfStatus="draw"Then'如果是绘图状态
IfX>OriginalXAndY>OriginalYThen'根据鼠标位置调整shape1的大小和位置
Shape1.MoveOriginalX,OriginalY,X-OriginalX,Y-OriginalY
ElseIfX
Shape1.MoveX,OriginalY,OriginalX-X,Y-OriginalY
ElseIfX>OriginalXAndY Shape1.MoveOriginalX,Y,X-OriginalX,OriginalY-Y ElseIfX Shape1.MoveX,Y,OriginalX-X,OriginalY-Y EndIf Info=Shape1.Width&"x"&Shape1.Height'显示当前区域的大小 LblPos.MoveShape1.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) IfShape1.Left<0ThenShape1.Left=0'使区域不超过屏幕 IfShape1.Top<0ThenShape1.Top=0 IfShape1.Left+Shape1.Width>Screen.Width/15
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- VB6 屏幕 截图