有其他办法获取网页某IMG元素的图像么
比如用webbrowser打开地址 http://www.xici.net/user/reg.asp目的想在picture上显示出当前网页验证码的图像
目前大家貌似都是用下面这个方法获取的
Set CtrlRange = WebBrowser1.Document.body.createControlRange()
CtrlRange.Add WebBrowser1.getelementbyid("showverifyimg")
CtrlRange.execCommand ("Copy")
Picture1.Picture = Clipboard.GetData
但是感觉不太方便
用读取图片缓存地址的方法，有的网站读取不到，不知道为什么
还有没有其他的方法呢？？？？？求代码
--------------------编程问答--------------------
--------------------编程问答--------------------
Private Sub CommandButton1_Click()
Dim arr() As Byte
On Error Resume Next
Set ms = CreateObject("msscriptcontrol.scriptcontrol")
ms.Language = "JavaScript"
With CreateObject("WinHttp.WinHttpRequest.5.1")
.Open "GET", "http://www.xici.net/user/reg.asp", False
.setRequestHeader "Connection", "Keep-Alive"
.Send
.Open "POST", "http://www.xici.net/setcode.asp", False
.setRequestHeader "Referer", "http://www.xici.net/user/reg.asp"
.setRequestHeader "x-requested-with", "XMLHttpRequest"
.setRequestHeader "Accept", "application/json, text/javascript, */*; q=0.01"
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
.setRequestHeader "Connection", "Keep-Alive"
.Send "act=setkeyvalue"
tt1 = Split(.responsetext, """")(3)
.Open "GET", "http://www.xici.net/xiciservice/verifyimg2.asp?key=" & tt1, False
.setRequestHeader "Referer", "http://www.xici.net/user/reg.asp"
.setRequestHeader "Connection", "Keep-Alive"
.Send '获得验证码
arr = .responseBody
Open "D:\tp1.gif" For Binary As #1
Put #1, , arr
Close #1
Do Until Dir("D:\tp1.gif") <> ""
DoEvents
Loop
ActiveSheet.Cells(2, 2).Select
Set s = ActiveSheet.Pictures.Insert("D:\tp1.gif")
s.ShapeRange.ScaleWidth 2, msoFalse, msoScaleFromTopLeft
s.ShapeRange.ScaleHeight 2, msoFalse, msoScaleFromTopLeft
sryzm = InputBox("请输入验证码")
s.Delete
Set WshShell = CreateObject("WScript.Shell")
WshShell.Run Environ$("comspec") & " /c Del /F /Q """ & "D:\tp1.gif""", vbHide, False
Set WshShell = Nothing
End With
End Sub
谢谢你的回复，但是我不想要这样的
我之所以用webbrowser,是有一定原因的，如果可以用其他的我就不用webbrowser了
现在我是想在软件的picture控件上显示某个网页图片元素的图像，因为有的时候图片不在可见范围内，移动显示很不方便
--------------------编程问答--------------------
你的意思，是用internetexplorer.application方法吗？
--------------------编程问答--------------------
--------------------编程问答--------------------
Public Const ERROR_CACHE_FiND_FAiL As Long = 0
Public Const ERROR_CACHE_FiND_SUCCESS As Long = 1
Public Const ERROR_FiLE_NOT_FOUND As Long = 2
Public Const ERROR_ACCESS_DENiED As Long = 5
Public Const ERROR_iNSUFFiCiENT_BUFFER As Long = 122
Public Const MAX_PATH As Long = 260
Public Const MAX_CACHE_ENTRY_iNFO_SiZE As Long = 4096
Public Const LMEM_FiXED As Long = &H0
Public Const LMEM_ZEROiNiT As Long = &H40
Public Const LPTR As Long = (LMEM_FiXED Or LMEM_ZEROiNiT)
Public Const NORMAL_CACHE_ENTRY As Long = &H1
Public Const EDiTED_CACHE_ENTRY As Long = &H8
Public Const TRACK_OFFLiNE_CACHE_ENTRY As Long = &H10
Public Const TRACK_ONLiNE_CACHE_ENTRY As Long = &H20
Public Const STiCKY_CACHE_ENTRY As Long = &H40
Public Const SPARSE_CACHE_ENTRY As Long = &H10000
Public Const COOKiE_CACHE_ENTRY As Long = &H100000
Public Const URLHiSTORY_CACHE_ENTRY As Long = &H200000
Public Const URLCACHE_FiND_DEFAULT_FiLTER As Long = NORMAL_CACHE_ENTRY Or COOKiE_CACHE_ENTRY Or URLHiSTORY_CACHE_ENTRY Or TRACK_OFFLiNE_CACHE_ENTRY Or TRACK_ONLiNE_CACHE_ENTRY Or STiCKY_CACHE_ENTRY
Public Type FiLETiME
dwLowDateTime As Long
dwHighDateTime As Long
End Type
Public Type iNTERNET_CACHE_ENTRY_iNFO
dwStructSize As Long
lpszSourceUrlName As Long
lpszLocalFileName As Long
CacheEntryType As Long
dwUseCount As Long
dwHitRate As Long
dwSizeLow As Long
dwSizeHigh As Long
LastModifiedTime As FiLETiME
ExpireTime As FiLETiME
LastAccessTime As FiLETiME
LastSyncTime As FiLETiME
lpHeaderinfo As Long
dwHeaderinfoSize As Long
lpszFileExtension As Long
dwExemptDelta As Long
End Type
Public Declare Function URLDownloadToFile Lib "urlmon" Alias "URLDownloadToFileA" (ByVal pCaller As Long, ByVal szURL As String, ByVal szFileName As String, ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
Public Declare Function FindFirstUrlCacheEntry Lib "wininet" Alias "FindFirstUrlCacheEntryA" (ByVal lpszUrlSearchPattern As String, lpFirstCacheEntryinfo As Any, lpdwFirstCacheEntryinfoBufferSize As Long) As Long
Public Declare Function FindNextUrlCacheEntry Lib "wininet" Alias "FindNextUrlCacheEntryA" (ByVal hEnumHandle As Long, lpNextCacheEntryinfo As Any, lpdwNextCacheEntryinfoBufferSize As Long) As Long
Public Declare Function FindCloseUrlCache Lib "wininet" (ByVal hEnumHandle As Long) As Long
Public Declare Function DeleteUrlCacheEntry Lib "wininet" Alias "DeleteUrlCacheEntryA" (ByVal lpszUrlName As String) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (pDest As Any, pSource As Any, ByVal dwLength As Long)
Public Declare Function lstrcpyA Lib "kernel32" (ByVal RetVal As String, ByVal Ptr As Long) As Long
Public Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long
Public Declare Function LocalAlloc Lib "kernel32" (ByVal uFlags As Long, ByVal uBytes As Long) As Long
Public Declare Function LocalFree Lib "kernel32" (ByVal hMem As Long) As Long
Sub qinli_ie_fc()
Dim icei As iNTERNET_CACHE_ENTRY_iNFO
Dim hFile As Long
Dim cachefile As String
Dim posUrl As Long
Dim posEnd As Long
Dim dwBuffer As Long
Dim pntrICE As Long
Dim arr(0 To 10000)
hFile = FindFirstUrlCacheEntry(0&, ByVal 0, dwBuffer)
k = 0
If (hFile = ERROR_CACHE_FiND_FAiL) And (Err.LastDllError = ERROR_iNSUFFiCiENT_BUFFER) Then
pntrICE = LocalAlloc(LMEM_FiXED, dwBuffer)
If pntrICE <> 0 Then
CopyMemory ByVal pntrICE, dwBuffer, 4
hFile = FindFirstUrlCacheEntry(vbNullString, ByVal pntrICE, dwBuffer)
If hFile <> ERROR_CACHE_FiND_FAiL Then
Do
CopyMemory icei, ByVal pntrICE, Len(icei)
If (icei.CacheEntryType And NORMAL_CACHE_ENTRY) = NORMAL_CACHE_ENTRY Then
cachefile = GetStrFromPtrA(icei.lpszSourceUrlName)
arr(k) = cachefile
k = k + 1
Cells(k, 1) = cachefile
End If
Call LocalFree(pntrICE)
dwBuffer = 0
Call FindNextUrlCacheEntry(hFile, ByVal 0, dwBuffer)
pntrICE = LocalAlloc(LMEM_FiXED, dwBuffer)
CopyMemory ByVal pntrICE, dwBuffer, 4
Loop While FindNextUrlCacheEntry(hFile, ByVal pntrICE, dwBuffer)
End If
End If
End If
Call LocalFree(pntrICE)
Call FindCloseUrlCache(hFile)
For cnt = 0 To UBound(arr)
cachefile = arr(cnt)
If InStr(cachefile, "Cookie") = 0 Then
Call DeleteUrlCacheEntry(cachefile)
End If
Next
End Sub
Public Function GetStrFromPtrA(ByVal lpszA As Long) As String
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function
Sub 读取mLogin_js文件()
qinli_ie_fc
On Error Resume Next
With CreateObject("internetexplorer.application")
.Visible = True
.Navigate "http://www.xici.net/user/reg.asp"
Do Until .ReadyState = 4
DoEvents
Loop
End With
Dim icei As iNTERNET_CACHE_ENTRY_iNFO
Dim hFile As Long
Dim cachefile As String
Dim posUrl As Long
Dim posEnd As Long
Dim dwBuffer As Long
Dim pntrICE As Long
Dim leiji As Integer
hFile = FindFirstUrlCacheEntry(0&, ByVal 0, dwBuffer)
If (hFile = ERROR_CACHE_FiND_FAiL) And (Err.LastDllError = ERROR_iNSUFFiCiENT_BUFFER) Then
pntrICE = LocalAlloc(LMEM_FiXED, dwBuffer)
If pntrICE <> 0 Then
CopyMemory ByVal pntrICE, dwBuffer, 4
hFile = FindFirstUrlCacheEntry(vbNullString, ByVal pntrICE, dwBuffer)
If hFile <> ERROR_CACHE_FiND_FAiL Then
Do
CopyMemory icei, ByVal pntrICE, Len(icei)
If (icei.CacheEntryType And NORMAL_CACHE_ENTRY) = NORMAL_CACHE_ENTRY Then
cachefile = GetStrFromPtrA(icei.lpszSourceUrlName)
If cachefile Like "http://www.xici.net/xiciservice/verifyimg2.asp?key=*" Then
URLDownloadToFile 0, cachefile, "d:\图片.gif", 0, 0
End If
End If
Call LocalFree(pntrICE)
dwBuffer = 0
Call FindNextUrlCacheEntry(hFile, ByVal 0, dwBuffer)
pntrICE = LocalAlloc(LMEM_FiXED, dwBuffer)
CopyMemory ByVal pntrICE, dwBuffer, 4
Loop While FindNextUrlCacheEntry(hFile, ByVal pntrICE, dwBuffer)
End If
End If
End If
Call LocalFree(pntrICE)
Call FindCloseUrlCache(hFile)
With CreateObject("internetexplorer.application")
.Visible = True
.Navigate "d:\图片.gif"
Do Until .ReadyState = 4
DoEvents
Loop
End With
End Sub
谢谢，请问，我用浏览器打开
http://reg.email.163.com/unireg/call.do?cmd=register.entrance&from=email163®Page=163
这个页面，刷新几下验证码
Private Sub Command1_Click()
Dim icei As iNTERNET_CACHE_ENTRY_iNFO
Dim hFile As Long
Dim cachefile As String
Dim posUrl As Long
Dim posEnd As Long
Dim dwBuffer As Long
Dim pntrICE As Long
Dim leiji As Integer
hFile = FindFirstUrlCacheEntry(0&, ByVal 0, dwBuffer)
If (hFile = ERROR_CACHE_FiND_FAiL) And (Err.LastDllError = ERROR_iNSUFFiCiENT_BUFFER) Then
pntrICE = LocalAlloc(LMEM_FiXED, dwBuffer)
If pntrICE <> 0 Then
CopyMemory ByVal pntrICE, dwBuffer, 4
hFile = FindFirstUrlCacheEntry(vbNullString, ByVal pntrICE, dwBuffer)
If hFile <> ERROR_CACHE_FiND_FAiL Then
Do
CopyMemory icei, ByVal pntrICE, Len(icei)
If (icei.CacheEntryType And NORMAL_CACHE_ENTRY) = NORMAL_CACHE_ENTRY Then
cachefile = GetStrFromPtrA(icei.lpszSourceUrlName)
If cachefile Like "*http://reg.email.163.com/unireg/call.do[?]cmd=register.verifyCode&v=common/verifycode/vc_en&env=*" Then
Set Picture1 = LoadPicture(GetStrFromPtrA(icei.lpszLocalFileName))
MsgBox cachefile, , GetStrFromPtrA(icei.lpszLocalFileName)
End If
End If
Call LocalFree(pntrICE)
dwBuffer = 0
Call FindNextUrlCacheEntry(hFile, ByVal 0, dwBuffer)
pntrICE = LocalAlloc(LMEM_FiXED, dwBuffer)
CopyMemory ByVal pntrICE, dwBuffer, 4
Loop While FindNextUrlCacheEntry(hFile, ByVal pntrICE, dwBuffer)
End If
End If
End If
Call LocalFree(pntrICE)
Call FindCloseUrlCache(hFile)
End Sub
Public Function GetStrFromPtrA(ByVal lpszA As Long) As String
GetStrFromPtrA = String$(lstrlenA(ByVal lpszA), 0)
Call lstrcpyA(ByVal GetStrFromPtrA, ByVal lpszA)
End Function
然后用你这个代码尝试下获取验证码图片的缓存文件地址，为什么获取不到呢？？？
--------------------编程问答--------------------
有的是没缓存的,简单一点,你在软件中模拟刷新一下验证码,这个时候用VB做个WINSOCK 代理,80端口连一下,这样就直接把图片的二进制数据读出来了,读完了马上关闭IE代理,这样是最实在的,还有一种方法是HOOK一下,一般情况下,是HOOK WINNET.DLL,或者是HOOK有关WINHTTP的函数
--------------------编程问答--------------------
还有一种方法是做接口,有个IE什么的TLB文件,应该有办法把所有的相关文件的下载,打开,全接口下来,这样就有办法取出二进制内容了
--------------------编程问答--------------------
Public Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Public Declare Function CloseClipboard Lib "user32" () As Long
Public Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Const CF_DIB = 8
Sub ie同步下载验证码()
Dim img
Dim CtrlRange
Dim bytClipData() As Byte
Dim crr() As Byte
Dim brr(0 To 13) As Byte
On Error Resume Next
For j = 0 To 13
brr(j) = 0
Next j
brr(0) = 66
brr(1) = 77
brr(2) = 70
brr(3) = 14
brr(10) = 54
With CreateObject("internetExplorer.application")
.Visible = True
.Navigate "http://reg.email.163.com/unireg/call.do?cmd=register.entrance&from=email163®Page=163"
Do Until .ReadyState = 4
DoEvents
Loop
Set img = .document.getElementById("vcodeImg")
Set CtrlRange = .document.body.createControlRange()
CtrlRange.Add img
CtrlRange.execCommand "Copy", True 'internet 选项——>安全——>脚本——>允许对剪贴板进行编程访问——>启用
Dim hMem As Long, lpData As Long
OpenClipboard 0&
hMem = GetClipboardData(8)
If CBool(hMem) Then
lpData = GlobalLock(hMem)
lClipSize = GlobalSize(hMem)
If lpData <> 0 And lClipSize > 0 Then
ReDim bytClipData(0 To lClipSize - 1)
CopyMemory bytClipData(0), ByVal lpData, lClipSize
End If
GlobalUnlock hMem
End If
CloseClipboard
Open "c:\123.bmp" For Binary Access Write As #1
Put #1, , brr
Put #1, , bytClipData
Close #1
ActiveSheet.Cells(2, 2).Select
Set vCode = ActiveSheet.Pictures.Insert("c:\123.bmp")
ActiveSheet.Cells(2, 1).Select
Kill "c:\123.bmp"
'.Quit
End With
End Sub
补充：VB , 基础类
