VB调用迅雷开放下载组件异常!

ccc598914010 2021-05-16 01:04:07
因为要下载程序,属于局域网,VB无法下载超过2G文件,不然就报错。
就想着利用迅雷开放组件下载超过2G的文件,但是无法正常下载。
有没有高手看看这个代码哪里出问题了。
此代码来源于网络!

下载win10的ISO镜像时,虽然能下载下来,但是数据有问题!好像没有完全下载。也没有下载完成提示。

http://www.vbgood.com/forum.php?mod=attachment&aid=NDAzNTR8NTNlMDUxOGZ8MTYyMTA5NTIyOHwwfDEwNDM0Mw%3D%3D

Option Explicit

Public Declare Function XLInitDownloadEngine Lib "XLDownload.dll" () As Long
Public Declare Function XLURLDownloadToFile Lib "XLDownload.dll" (ByRef pszFileName As Any, ByRef pszUrl As Any, ByRef pszRefUrl As Any, ByRef lTaskId As Long) As Long
Public Declare Function XLQueryTaskInfo Lib "XLDownload.dll" (ByVal lTaskId As Long, ByRef plStatus As Long, ByRef pullFileSize As Currency, ByRef pullRecvSize As Currency) As Long
Public Declare Function XLPauseTask Lib "XLDownload.dll" (ByVal lTaskId As Long, ByRef lNewTaskId As Long) As Long
Public Declare Function XLContinueTask Lib "XLDownload.dll" (ByVal lTaskId As Long) As Long
Public Declare Function XLContinueTaskFromTdFile Lib "XLDownload.dll" (ByRef pszTdFileFullPath As Any, ByRef lTaskId As Long) As Long
Public Declare Sub XLStopTask Lib "XLDownload.dll" (ByVal lTaskId As Long)
Public Declare Function XLUninitDownloadEngine Lib "XLDownload.dll" () As Long
Public Declare Function XLGetErrorMsg Lib "XLDownload.dll" (ByVal dwErrorId As Long, ByVal pszBuffer As Any, ByRef dwSize As Long) As Long

Public Enum enumTaskStatus
enumTaskStatus_Connect = 0 ', // 已经建立链接
enumTaskStatus_Download = 2 ', // 开始下载
enumTaskStatus_Pause = 10 ', // 暂停
enumTaskStatus_Success = 11 ', //成功下载
enumTaskStatus_Fail = 12 ', // 下载失败
End Enum

Public Const XL_SUCCESS As Long = 0
Public Const XL_ERROR_FAIL As Long = &H10000000

'//尚未进行初始化
Public Const XL_ERROR_UNINITAILIZE As Long = XL_ERROR_FAIL + 1

'// 不支持的协议,只支持HTTP与FTP
Public Const XL_ERROR_UNSPORTED_PROTOCOL As Long = XL_ERROR_FAIL + 2

'// 初始化托盘图标失败
Public Const XL_ERROR_INIT_TASK_TRAY_ICON_FAIL As Long = XL_ERROR_FAIL + 3

'//添加托盘图标失败
Public Const XL_ERROR_ADD_TASK_TRAY_ICON_FAIL As Long = XL_ERROR_FAIL + 4

'// 指针为空
Public Const XL_ERROR_POINTER_IS_NULL As Long = XL_ERROR_FAIL + 5

'// 字符串是空串
Public Const XL_ERROR_STRING_IS_EMPTY As Long = XL_ERROR_FAIL + 6

'// 传入的路径没有包含文件名
Public Const XL_ERROR_PATH_DONT_INCLUDE_FILENAME As Long = XL_ERROR_FAIL + 7

'// ´创建目录失败
Public Const XL_ERROR_CREATE_DIRECTORY_FAIL As Long = XL_ERROR_FAIL + 8

'//内存不足
Public Const XL_ERROR_MEMORY_ISNT_ENOUGH As Long = XL_ERROR_FAIL + 9

'// 参数不合法
Public Const XL_ERROR_INVALID_ARG As Long = XL_ERROR_FAIL + 10

'// 任务不存在
Public Const XL_ERROR_TASK_DONT_EXIST As Long = XL_ERROR_FAIL + 11

'//文件名不合法
Public Const XL_ERROR_FILE_NAME_INVALID As Long = XL_ERROR_FAIL + 12

'// 没有实现
Public Const XL_ERROR_NOTIMPL As Long = XL_ERROR_FAIL + 13

'// 创建的任务达到上限,无法继续创建
Public Const XL_ERROR_TASKNUM_EXCEED_MAXNUM As Long = XL_ERROR_FAIL + 14



Option Explicit

Dim lTaskId As Long
Dim dwRet As Long
Dim ullFileSize As Currency
Dim ullRecvSize As Currency
Dim lStatus As Long
Dim Inited As Boolean
Dim Paused As Boolean

Private Sub Command1_Click()

If XLInitDownloadEngine = 0 Then
Label1.Caption = "初始化引擎失败"
Exit Sub
Else
Inited = True
End If

Dim tdFilePath As String

tdFilePath = App.Path & "\hfyg.exe.td"

dwRet = XLContinueTaskFromTdFile(ByVal StrPtr(tdFilePath), lTaskId)
If dwRet <> XL_SUCCESS Then
MsgBox "继续任务失败"
Else
Timer1.Enabled = True
Timer1.Interval = 1000
Label1.Caption = "继续下载, TaskId=" & lTaskId
Command4.Enabled = False
End If
End Sub

Private Sub Command2_Click()
If XLInitDownloadEngine = 0 Then
Label1.Caption = "初始化引擎失败."
Exit Sub
Else
Inited = True
End If

Dim url As String
Dim filePath As String

filePath = Text2.Text
url = Text1.Text

dwRet = XLURLDownloadToFile(ByVal StrPtr(filePath), ByVal StrPtr(url), ByVal StrPtr(""), lTaskId)
If dwRet <> XL_SUCCESS Then
MsgBox "添加任务失败"
Else
Timer1.Enabled = True
Timer1.Interval = 1000
Label1.Caption = "开始下载, TaskId=" & lTaskId

Command3.Enabled = True
End If
End Sub

Private Sub Command3_Click()
Dim lNewTaskId As Long

If Paused = True Then
dwRet = XLContinueTask(lTaskId)
If dwRet <> XL_SUCCESS Then
Label1.Caption = "继续失败"
Exit Sub
Else
Label1.Caption = "继续下载, TaskId=" & lTaskId
Paused = False
Timer1.Enabled = True
End If
Else
Timer1.Enabled = False
dwRet = XLPauseTask(lTaskId, lNewTaskId)
If dwRet <> XL_SUCCESS Then
Label1.Caption = "暂停失败"
Exit Sub
Else
Label1.Caption = "暂停下载"
lTaskId = lNewTaskId
Paused = True
End If
End If
End Sub

Private Sub Form_Load()
lTaskId = -1
Call Text1_Change
End Sub

Private Sub Form_Unload(Cancel As Integer)
If lTaskId <> -1 Then
Label1.Caption = "停止任务, TaskId=" & lTaskId
Me.Refresh
XLStopTask lTaskId
End If

If Inited Then
XLUninitDownloadEngine
End If
End Sub

Private Sub Text1_Change()
On Error Resume Next
Text2.Text = App.Path & "\" & Mid(Text1.Text, InStrRev(Text1.Text, "/") + 1)

If Dir(Text2.Text) <> "" Or Dir(Text2.Text & ".td") <> "" Then
Command4.Enabled = True
If Dir(Text2.Text & ".td") <> "" Then
Command1.Enabled = True
Else

End If
Else
Command2.Enabled = True
Command1.Enabled = False
Command3.Enabled = False
Command4.Enabled = False
End If
End Sub

Private Sub Command4_Click()
On Error Resume Next
If Dir(Text2.Text) <> "" Then
Kill Text2.Text
End If
If Dir(Text2.Text & ".td") <> "" Then
Kill Text2.Text & ".td"
Kill Text2.Text & ".td.cfg"
End If
Call Text1_Change
End Sub

Private Sub Timer1_Timer()
dwRet = XLQueryTaskInfo(lTaskId, lStatus, ullFileSize, ullRecvSize)
If XL_SUCCESS = dwRet Then
'// 输入进度信息
Label1.Caption = "正在下载 " & ullRecvSize & "/" & ullFileSize
Else
Label1.Caption = "查询状态失败"
End If
End Sub
...全文
2889 9 打赏 收藏 转发到动态 举报
AI 作业
写回复
用AI写文章
9 条回复
切换为时间正序
请发表友善的回复…
发表回复
milaoshu1020 2021-05-19
  • 打赏
  • 举报
回复
引用 5 楼 ccc598914010 的回复:
我看了下,网上没有这个示例,这个需要下载aria2安装,才能调用吧!哎!我在琢磨琢磨吧!
只需要一个aria2.exe文件,不需要安装,放在程序目录中就行,我给的示例文件压缩包中就包含这个文件了; 支持的下载协议有: http/ftp/magnet(bt) ...
ccc598914010 2021-05-18
  • 打赏
  • 举报
回复
不早说!早说我留着了!几天没人回!我就结贴了!
milaoshu1020 2021-05-18
  • 打赏
  • 举报
回复
别着急结贴呀,我给你写了一个示例程序,代码如下: cAria2.cls

Option Explicit
' xmlrpc 接口参考地址: http://aria2.github.io/manual/en/html/aria2c.html#rpc-interface

Public RpcUri As String
Private XmlHttp As MSXML2.XMLHTTP60

Public Sub launchDaemon(ByVal blnVisible As Boolean)
    Shell App.Path & "\aria2c.exe --enable-rpc=true --dir=""" & App.Path & """", IIf(blnVisible, vbMinimizedNoFocus, vbHide)
End Sub

Public Function addUri(strUri As String)
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.addUri</methodName><params><param><value><array><data><value><string>" & strUri & "</string></value></data></array></value></param></params></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
    
    Set objXml = XmlHttp.responseXML
    
    Dim objElem As IXMLDOMElement
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/string")
    If Not objElem Is Nothing Then
        addUri = objElem.Text
    Else
        Set addUri = objXml
    End If
End Function

Public Function remove(strGid As String)
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.remove</methodName><params><param><value>" & strGid & "</value></param></params></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
    
    Set objXml = XmlHttp.responseXML
    
    Dim objElem As IXMLDOMElement
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/string")
    If Not objElem Is Nothing Then
        remove = objElem.Text
    Else
        Set remove = objXml
    End If
End Function

Public Function pause(strGid As String)
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.pause</methodName><params><param><value>" & strGid & "</value></param></params></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
    
    Set objXml = XmlHttp.responseXML
    
    Dim objElem As IXMLDOMElement
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/string")
    If Not objElem Is Nothing Then
        pause = objElem.Text
    Else
        Set pause = objXml
    End If
End Function

Public Sub pauseAll()
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.pauseAll</methodName></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
End Sub

Public Function unpause(strGid As String)
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.unpause</methodName><params><param><value>" & strGid & "</value></param></params></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
    
    Set objXml = XmlHttp.responseXML
    
    Dim objElem As IXMLDOMElement
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/string")
    If Not objElem Is Nothing Then
        unpause = objElem.Text
    Else
        Set unpause = objXml
    End If
End Function

Public Sub unpauseAll()
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.unpauseAll</methodName></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
End Sub

Public Function tellStatus(strGid As String)
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.tellStatus</methodName><params><param><value>" & strGid & "</value></param></params></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
    
    Set tellStatus = XmlHttp.responseXML
End Function

Public Sub shutdown()
    Dim strXml As String
    strXml = "<?xml version=""1.0""?><methodCall><methodName>aria2.shutdown</methodName></methodCall>"
    
    Dim objXml As New DOMDocument60
    objXml.loadXML strXml
    
    XmlHttp.open "POST", RpcUri, False
    XmlHttp.send objXml.xml
End Sub

Private Sub Class_Initialize()
    RpcUri = "http://localhost:6800/rpc"
    Set XmlHttp = New MSXML2.XMLHTTP60
End Sub

Form1

Option Explicit

Private objAria2 As New CAria2
Private gid As String

Private Sub cmdPause_Click()
    objAria2.pause gid
End Sub

Private Sub cmdStartDownload_Click()
    tmrStatus.Enabled = True
    gid = objAria2.addUri(txtUri)
End Sub

Private Sub cmdRemove_Click()
    tmrStatus.Enabled = False
    objAria2.remove gid
End Sub

Private Sub cmdUnpause_Click()
    objAria2.unpause gid
End Sub

Private Sub Form_Load()
    objAria2.launchDaemon True ' 如果不想显示控制台窗口,可以设为False;
End Sub

Private Sub Form_Unload(Cancel As Integer)
    objAria2.shutdown
End Sub

Private Sub tmrStatus_Timer()
    Dim objXml As DOMDocument60
    Set objXml = objAria2.tellStatus(gid)
    
    pbDownload.Min = 0
    
    Dim objElem As IXMLDOMElement
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/struct/member[name='files']/value/array/data/value/struct/member[name='length']/value/string")
    
    Dim strMax As String
    strMax = "0"
    
    If Not objElem Is Nothing Then
        pbDownload.Max = CSng(objElem.Text)
        strMax = objElem.Text
    End If
    
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/struct/member[name='files']/value/array/data/value/struct/member[name='completedLength']/value/string")
    
    Dim strValue As String
    strValue = "0"
    
    If Not objElem Is Nothing Then
        pbDownload.Value = CSng(objElem.Text)
        strValue = objElem.Text
    End If
    
    If strValue = strMax And strMax <> "0" Then
        tmrStatus.Enabled = False
    End If
    
    Set objElem = objXml.selectSingleNode("/methodResponse/params/param/value/struct/member[name='status']/value/string")
    
    If Not objElem Is Nothing Then
        StatusBar1.SimpleText = objElem.Text & " " & strValue & "/" & strMax
    End If
End Sub
下载地址: 链接:https://pan.baidu.com/s/1tOcl5IAQxxDlFBF1OgwGYA 提取码:18bi 运行示例:
ccc598914010 2021-05-18
  • 打赏
  • 举报
回复
自己已经解决!!!
milaoshu1020 2021-05-16
  • 打赏
  • 举报
回复
调用aria2命令行下载即可: aria2c http://xz.lpxt.com/win10/WINDOWS10_X64_20H2ZJB.iso
ccc598914010 2021-05-16
  • 打赏
  • 举报
回复
引用 4 楼 milaoshu1020 的回复:
直接调用shell函数运行就行了,不用组件: 第1种方式:

Shell("aria2c http://xz.lpxt.com/win10/WINDOWS10_X64_20H2ZJB.iso",VbNormalFocus)
第2种方式:

set wsh = createobject("wscript.shell")
wsh.run "aria2c http://xz.lpxt.com/win10/WINDOWS10_X64_20H2ZJB.iso",1,True
第2种方式的好处是可以等待下载完毕,然后再继续执行后续操作; 当然你要是想即时得到下载进度,进行暂停,继续,删除任务等操作;你就需要深入研究aria2了,应该是可以的,我也再研究研究,看能不能做个ActiveX DLL来实现这些功能;
我看了下,网上没有这个示例,这个需要下载aria2安装,才能调用吧!哎!我在琢磨琢磨吧!
milaoshu1020 2021-05-16
  • 打赏
  • 举报
回复
直接调用shell函数运行就行了,不用组件: 第1种方式:

Shell("aria2c http://xz.lpxt.com/win10/WINDOWS10_X64_20H2ZJB.iso",VbNormalFocus)
第2种方式:

set wsh = createobject("wscript.shell")
wsh.run "aria2c http://xz.lpxt.com/win10/WINDOWS10_X64_20H2ZJB.iso",1,True
第2种方式的好处是可以等待下载完毕,然后再继续执行后续操作; 当然你要是想即时得到下载进度,进行暂停,继续,删除任务等操作;你就需要深入研究aria2了,应该是可以的,我也再研究研究,看能不能做个ActiveX DLL来实现这些功能;
ccc598914010 2021-05-16
  • 打赏
  • 举报
回复
引用 1 楼 milaoshu1020 的回复:
调用aria2命令行下载即可: aria2c http://xz.lpxt.com/win10/WINDOWS10_X64_20H2ZJB.iso
迅雷的开放组件不支持Aria2! 有支持VB的aria2c组件吗?
ccc598914010 2021-05-16
  • 打赏
  • 举报
回复
迅雷的开放组件不支持Aria2! 有支持VB的aria2c组件吗?

1,502

社区成员

发帖
与我相关
我的任务
社区描述
VB 网络编程
社区管理员
  • 网络编程
加入社区
  • 近7日
  • 近30日
  • 至今
社区公告
暂无公告

试试用AI创作助手写篇文章吧