用VB6屏幕截图Word格式.docx
- 文档编号:4468620
- 上传时间:2023-05-03
- 格式:DOCX
- 页数:18
- 大小:33.73KB
用VB6屏幕截图Word格式.docx
《用VB6屏幕截图Word格式.docx》由会员分享,可在线阅读,更多相关《用VB6屏幕截图Word格式.docx(18页珍藏版)》请在冰点文库上搜索。
注释不用了吧,用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"
(ByValhWndAsLong,ByValhdcBltAsLong,ByValnFlagsAsLong)AsLong
PrivateDeclareFunctionBitBltLib"
(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"
注意,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"
(lpRectAsRECT,ByValXAsLong,ByValYAsLong)AsLong
PrivateDeclareFunctionCreateDCLib"
Alias"
CreateDCA"
(ByVallpDriverNameAsString,ByVallpDeviceNameAsString,ByVallpOutputAsString,lpInitDataAsLong)AsLong
(ByValhDestDCAsLong,ByValXAsLong,ByValYAsLong,ByValnWidthAsLong,ByValnHeightAsLong,ByValhSrcDCAsLong,ByValxSrcAsLong,ByValySrcAsLong,ByValdwRopAsLong)AsLong
PrivateDeclareFunctionGetPixelLib"
(ByValhdcAsLong,ByValXAsLong,ByValYAsLong)AsLong
PrivateDeclareFunctionSetWindowPosLib"
(ByValhwndAsLong,ByValhWndInsertAfterAsLong,ByValXAsLong,ByValYAsLong,ByValCxAsLong,ByValCyAsLong,ByValwFlagsAsLong)AsLong
PrivateDeclareFunctionCreateCompatibleDCLib"
(ByValhdcAsLong)AsLong
PrivateDeclareFunctionCreateCompatibleBitmapLib"
(ByValhdcAsLong,ByValnWidthAsLong,ByValnHeightAsLong)AsLong
PrivateDeclareFunctionSelectObjectLib"
(ByValhdcAsLong,ByValhObjectAsLong)AsLong
PrivateDeclareFunctionGetDesktopWindowLib"
()AsLong
PrivateDeclareFunctionOpenClipboardLib"
(ByValhwndAsLong)AsLong
PrivateDeclareFunctionEmptyClipboardLib"
PrivateDeclareFunctionSetClipboardDataLib"
(ByValwFormatAsLong,ByValhMemAsLong)AsLong
PrivateDeclareFunctionCloseClipboardLib"
PrivateDeclareFunctionDeleteDCLib"
PrivateDeclareFunctionReleaseDCLib"
(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
**修改人:
2005-10-2420.11.23
**版本:
Version1.2.1
PrivateSubGetRGBColors(ByValRGBColorAsLong,ByRefRedColorAsLong,ByRefGreenColorAsLong,ByRefBlueColorAsLong)
RedColor=RGBColorMod256
GreenColor=(RGBColor\&
H100)Mod256
BlueColor=(RGBColor\&
H10000)Mod256
EDcode
index(Integer)-提示编码
改变提示信息
2005-10-2617.49.54
PublicSubSetTitle(IndexAsInteger)
SelectCaseIndex
Case1
lblInfo(0).Caption="
*按住鼠标左键不放选择"
&
vbCrLf&
"
截图的范围."
lblInfo
(1).Caption="
*按ESC键退出."
lblInfo
(2).Caption="
"
Case2
*松开鼠标左键确定截图"
的范围."
Case3
*用鼠标左键调整截图的"
位置."
*双击选取区域保存图片."
EndSelect
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'
设置提示的内容
PrivateSubForm_KeyPress(KeyAsciiAsInteger)
IfKeyAscii=vbKeyEscapeThen
UnloadMe
EndIf
PrivateSubTimer1_Timer()
Picture1.Top=Picture1.Top+4'
模拟QQ截屏时的左上角的提示图片的效果
IfPicture1.Top>
0Then
Timer1.Enabled=False
PrivateSubForm_MouseDown(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
IfStatus="
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'
则移动区域
否则重新画一个区域
OriginalY=Y
状态恢复到抓取
CallSetTitle
(2)
PrivateSubForm_MouseUp(ButtonAsInteger,ShiftAsInteger,XAsSingle,YAsSingle)
IfButton=1Then
CallSetTitle(3)
Then
move"
OriginalX=Shape1.Left'
更新OriginalX,因为选择区域时可能会出现shape的right点大于left点
OriginalY=Shape1.Top
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
Shape1.Visible=False
LblPos.Visible=False
如果是绘图状态
IfX>
OriginalXAndY>
OriginalYThen'
根据鼠标位置调整shape1的大小和位置
Shape1.MoveOriginalX,OriginalY,X-OriginalX,Y-OriginalY
ElseIfX<
OriginalYThen
Shape1.MoveX,OriginalY,OriginalX-X,Y-OriginalY
ElseIfX>
OriginalXAndY<
Shape1.MoveOriginalX,Y,X-OriginalX,OriginalY-Y
Shape1.MoveX,Y,OriginalX-X,OriginalY-Y
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
如果是移动状态
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 屏幕 截图