下面这段代码使用的是internet control控件,不知道我说错没有。
只能下载IMG链接的图片,不能下载带有background的图片,请问各位大大,怎么修改代码才能下载到BACKGROUND代码呢?Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Const CF_HDROP = 15Dim oWin As SHDocVw.ShellWindows
Dim oIE As SHDocVw.InternetExplorerDim i As Integer
Dim iOldIndex As IntegerPrivate Sub ListAllImages() '在列表框lstIMG中列出选中IE窗口中所有的<IMG>标签指向的图片
'On Error Resume Next
Dim bytData() As Byte
Dim oIMG, oRange
Dim hMem As Long
Dim lpData As Long
Dim lClipSize As Long
Dim sFileName As String
Dim colURL As Collection
Dim colDomain As Collection
Set colURL = New Collection
Set colDomain = New Collection
Dim sDomain
Dim backg
lstIMG.Clear
lstDomain.Clear
lstIMG.ColumnCount = 3
i = 0
oIE.Document.ExecCommand ("Unselect")
For Each oIMG In oIE.Document.getelementsbytagname("img")
'从图片的src中提取出域名,赋给sDomain变量
sDomain = oIMG.src
sDomain = Mid(sDomain, InStr(sDomain, "//") + 2)
' sDomain = Left(sDomain, InStr(sDomain, "/") - 1)
'通过collection对象去除重复字符串
On Error Resume Next
colDomain.Add sDomain, sDomain
' sDomain = Left(sDomain, InStr(sDomain, "/") - 1)
'通过collection对象去除重复字符串
On Error GoTo 0
'通过ExecCommand可以复制IE中的图片,之后在剪贴板中找到CF_HDROP格式对应的数据即是该图片在本地电脑Internet临时文件夹中缓存文件的完整路径
Set oRange = oIE.Document.body.createControlRange()
oRange.Add (oIMG)
oRange.ExecCommand ("Copy")
If OpenClipboard(ByVal 0&) <> 0 Then '打开剪贴板
hMem = GetClipboardData(CF_HDROP) '获取剪贴板中CF_HDROP格式数据对应的内存对象句柄
If CBool(hMem) Then
lpData = GlobalLock(hMem) + 20 '获取第一个有效数据在内存中的位置
lClipSize = GlobalSize(hMem) - 20 '获取有效数据的字节长度
ReDim bytData(0 To lClipSize - 1) As Byte
CopyMemory bytData(0), ByVal lpData, lClipSize '复制数据到字节数组
GlobalUnlock (hMem)
'将字节数组转化为字符串后赋给sFileName字符串变量,这里得到的sFileName即是本地缓存图片文件的完整路径
'通常会是X:\....\Temporary Internet Files\logo[1].gif这样的形式
sFileName = StrConv(bytData, vbUnicode)
'通过Collection去掉重复的图片文件
On Error Resume Next
Err.Clear
colURL.Add oIMG.src, oIMG.src
If Err.Number = 0 Then
'在lstIMG列表框的第一列填写图片文件名(不包含路径)
lstIMG.AddItem Mid(oIMG.src, InStrRev(oIMG.src, "/") + 1)
'在lstIMG列表框的第二列填写图片文件完整的网络路径,如http://...../logo.gif
lstIMG.List(i, 1) = oIMG.src
'在lstIMG列表框的第三列填写图片文件在本地电脑上的缓存文件(包括完整路径)
lstIMG.List(i, 2) = sFileName
i = i + 1
End If
On Error GoTo 0
End If
CloseClipboard '关闭剪贴板
End If
Set oRange = Nothing
Next
AutoFit lstIMG
For i = 1 To colDomain.Count
lstDomain.AddItem colDomain.Item(i)
Next
Set colDomain = Nothing
Set colURL = Nothing
End Sub
只能下载IMG链接的图片,不能下载带有background的图片,请问各位大大,怎么修改代码才能下载到BACKGROUND代码呢?Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Const CF_HDROP = 15Dim oWin As SHDocVw.ShellWindows
Dim oIE As SHDocVw.InternetExplorerDim i As Integer
Dim iOldIndex As IntegerPrivate Sub ListAllImages() '在列表框lstIMG中列出选中IE窗口中所有的<IMG>标签指向的图片
'On Error Resume Next
Dim bytData() As Byte
Dim oIMG, oRange
Dim hMem As Long
Dim lpData As Long
Dim lClipSize As Long
Dim sFileName As String
Dim colURL As Collection
Dim colDomain As Collection
Set colURL = New Collection
Set colDomain = New Collection
Dim sDomain
Dim backg
lstIMG.Clear
lstDomain.Clear
lstIMG.ColumnCount = 3
i = 0
oIE.Document.ExecCommand ("Unselect")
For Each oIMG In oIE.Document.getelementsbytagname("img")
'从图片的src中提取出域名,赋给sDomain变量
sDomain = oIMG.src
sDomain = Mid(sDomain, InStr(sDomain, "//") + 2)
' sDomain = Left(sDomain, InStr(sDomain, "/") - 1)
'通过collection对象去除重复字符串
On Error Resume Next
colDomain.Add sDomain, sDomain
' sDomain = Left(sDomain, InStr(sDomain, "/") - 1)
'通过collection对象去除重复字符串
On Error GoTo 0
'通过ExecCommand可以复制IE中的图片,之后在剪贴板中找到CF_HDROP格式对应的数据即是该图片在本地电脑Internet临时文件夹中缓存文件的完整路径
Set oRange = oIE.Document.body.createControlRange()
oRange.Add (oIMG)
oRange.ExecCommand ("Copy")
If OpenClipboard(ByVal 0&) <> 0 Then '打开剪贴板
hMem = GetClipboardData(CF_HDROP) '获取剪贴板中CF_HDROP格式数据对应的内存对象句柄
If CBool(hMem) Then
lpData = GlobalLock(hMem) + 20 '获取第一个有效数据在内存中的位置
lClipSize = GlobalSize(hMem) - 20 '获取有效数据的字节长度
ReDim bytData(0 To lClipSize - 1) As Byte
CopyMemory bytData(0), ByVal lpData, lClipSize '复制数据到字节数组
GlobalUnlock (hMem)
'将字节数组转化为字符串后赋给sFileName字符串变量,这里得到的sFileName即是本地缓存图片文件的完整路径
'通常会是X:\....\Temporary Internet Files\logo[1].gif这样的形式
sFileName = StrConv(bytData, vbUnicode)
'通过Collection去掉重复的图片文件
On Error Resume Next
Err.Clear
colURL.Add oIMG.src, oIMG.src
If Err.Number = 0 Then
'在lstIMG列表框的第一列填写图片文件名(不包含路径)
lstIMG.AddItem Mid(oIMG.src, InStrRev(oIMG.src, "/") + 1)
'在lstIMG列表框的第二列填写图片文件完整的网络路径,如http://...../logo.gif
lstIMG.List(i, 1) = oIMG.src
'在lstIMG列表框的第三列填写图片文件在本地电脑上的缓存文件(包括完整路径)
lstIMG.List(i, 2) = sFileName
i = i + 1
End If
On Error GoTo 0
End If
CloseClipboard '关闭剪贴板
End If
Set oRange = Nothing
Next
AutoFit lstIMG
For i = 1 To colDomain.Count
lstDomain.AddItem colDomain.Item(i)
Next
Set colDomain = Nothing
Set colURL = Nothing
End Sub
解决方案 »
免费领取超大流量手机卡,每月29元包185G流量+100分钟通话, 中国电信官方发货