vb 抓屏的问题，给分100
本帖最后由 apple44444cn 于 2010-03-09 10:58:56 编辑 Private Declare Function GetDC Lib "user32" (ByVal hwnd 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 ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetForegroundWindow Lib "user32" () As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" (ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
'这是定义获得窗口句柄的API函数.
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long '这句是定义向获得窗口句柄发送按键消息的API函数.
加载flash的模块 给测试地址
http://s.okooo.com/StyleDefault/Media/OKoooExponent.swf?MatchID=145381
Sub url_add(url_addr As String)
sh1.Movie = ""
Me.WindowState = 2
Picture1.Height = Me.Height
Picture1.Width = Me.Width
sh1.Height = Me.Height
sh1.Width = Me.Width
sh1.Movie = url_addr
On Error Resume Next
For i = 1 To 100000000
If Abs(sh1.TotalFrames - sh1.FrameNum) = 2 Then
感觉问题出在这里，就是flash还没播放完就直接过去了
有大侠给的<=5,也不管用，为什么是2呢？程序运行的时候totalframes=2,framenum=0
Exit For
Else
DoEvents
End If
Next
End Sub
抓图的模块，句柄不懂，本是想要获取shockwave flash所在窗体的句柄的，但是好像捉到的是活动窗体的句柄
Sub catch_bmp(name As String)
Dim hdc As Long, hWNc As Long
Dim lngHwnd As Long
Picture1.Picture = LoadPicture()
Picture1.AutoRedraw = True
Picture1.Refresh
'hWNc = GetForegroundWindow()
'hWNc = FindWindow(Form2, "bmp_fr")
lngHwnd = FindWindowEx(Me.hwnd, 0, "Shell Embedding", vbNullString)
lngHwnd = FindWindowEx(lngHwnd, 0, "Shell DocObject View", vbNullString)
hdc = GetDC(lngHwnd)
BitBlt Picture1.hdc, -60, -600, 2870, 1630, hdc, 0, 0, vbSrcCopy
ReleaseDC 0, hdc
Picture1.AutoRedraw = False
Picture1.ScaleMode = 1
Picture1.Height = 425
Picture1.Width = 925
SavePicture Picture1.Image, App.Path & "" & name & ".jpg"
Picture1.Picture = LoadPicture()
End Sub
主程序，从excel读取flash地址的，测试地址上面发了一个
http://s.okooo.com/StyleDefault/Media/OKoooExponent.swf?MatchID=145381
再发一遍
Private Sub Command1_Click()
Dim xls As Excel.Workbook
Dim sht As Excel.Worksheet
Dim addr As String
Dim game_name As String
Set xls = Excel.Workbooks.Open("c:\11.xls")
For m = 2 To xls.Sheets.Count
Set sht = xls.Worksheets(m)
sht.Activate
For i = 1 To 1000000
If sht.Cells(i, 1) = "" Then
Exit For
Else
sht.Cells(i, 13).Select
addr = sht.Cells(i, 13)
game_name = sht.Cells(i, 1)
Call url_add(addr)
这两个模块之间应该有一个等待加载flash完毕的东东，不懂，所以没搞定
需要的是发 flash加载完毕时的抓图
Call catch_bmp(game_name)
End If
Next
Next
xls.Saved = True
xls.Close
End Sub
还有问题，就是我捕捉到的是当前活动的窗口而不是控件所在的窗口。我逐步执行可以得到我需要的结果，但是程序自动运行的时候抓到的图就是一张图了，统一的内容了。
[解决办法]
用不着搞那么复杂。Flash动画可直接按PrtscSysRq键抓到图，或者用普通抓图方法就可抓到图。
[解决办法]
按PrtscSysRq键抓到图,这个最简单实在
[解决办法]
楼主,楼上已有两位建议你用PrtscSysRq键了,你如有不适合用PrtscSysRq键的原因,不妨再说明一下:)
[解决办法]
要连续抓Flash图的话 自己再改一改即可
Option Explicit
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 Sub keybd_event Lib "user32" (ByVal bVk As Byte, ByVal bScan As Byte, ByVal dwFlags As Long, ByVal dwExtraInfo As Long)
Private Sub Form_Load()
Me.AutoRedraw = False
Me.BorderStyle = 0: Me.Caption = ""
Picture1.AutoRedraw = True
Picture1.AutoSize = True
Picture1.BorderStyle = 0
Picture1.Move Screen.Width
Picture2.BorderStyle = 0
Picture2.Width = ShockwaveFlash1.Width
Picture2.Height = ShockwaveFlash1.Height
Picture2.AutoRedraw = True
Picture2.Move Screen.Width
Me.Move (Screen.Width - Me.Width) \ 2, (Screen.Height - Me.Height) \ 2
ShockwaveFlash1.Movie = "c:\106.swf"
End Sub
Private Sub Command1_Click()
DoEvents
Call keybd_event(vbKeySnapshot, 1, 0, 0)
Call CatchPicture
End Sub
Private Sub Command2_Click()
Unload Me
End Sub
Sub CatchPicture()
DoEvents
Picture1.Picture = Clipboard.GetData(vbCFBitmap)
BitBlt Picture2.hDC, 0, 0, ShockwaveFlash1.Width \ 15, ShockwaveFlash1.Height \ 15, Picture1.hDC, ShockwaveFlash1.Left \ 15, ShockwaveFlash1.Top \ 15, vbSrcCopy
SavePicture Picture2.Image, "C:\TT.BMP"
'MsgBox "抓屏完成!"
End Sub
[解决办法]
首先感谢1楼的大侠。我问过两次他都是第一个回复我的。非常感谢。您和2楼的大哥说用抓屏键，问题是我需要连续抓很多，而且这里面还有个等待flash加载的过程。而现在最大的问题就出在这，我搞不定这个问题。
三楼的非常详细。非常感谢您。
[解决办法]
错了，是四楼的非常详细，也感谢三楼的贴心。
[解决办法]
4楼的刘兄,一般都是直接给源码,难得......
lz想连续抓屏,4楼的代码里加循环,加延时处理吧
[解决办法]
http://download.csdn.net/source/1785500
[解决办法]
