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
...全文
2896 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组件吗？
VB调用DLL资源文件
将项目图片、文字等使用VC++编写资源文件DLL提供给VB调用
VB仿迅雷下载悬浮框
VB仿迅雷下载悬浮框 VB完美模拟迅雷透明下载悬浮框。
解决 迅雷API无法成功调用的问题
网上找的的资料显示，迅雷的API还是比较强大的，可以基本实现对迅雷的控制。但是经过我的测试，除了添加任务外，其它的信息获取均是空的。 开始以为是我的计算机问题，但是更换的机器，问题依旧。后来更换了各种开发工具VB6、VB.net、C#.net等等均无法解决。 最后，我想到是不是迅雷更新导致的？于是找到以前光盘保留的一个老版本的迅雷，安装后问题解决，需要注意的是，要先卸载新版本，再安装老版本，原因是控件需要注册。 一下为能用的迅雷版本信息： 迅雷版本号：5.3.0.220 组件版本号：1.0.0.1 必须使用这个DLL，才能实现网上现在公布的 迅雷API接口 否则，安装了新版的迅雷，只能实现下载任务的添加，无法得到任何反馈。
调用ThunderAgent，实现迅雷局域网版的开发
　　对于个人家庭用户，使用迅雷可以最大化利用带宽，但这种方式在局域网环境下就严重影响其他用户了。 　　针对此问题，迅雷公司推出了“网吧版迅雷”，试图解决此项问题。但经过笔者使用，发现实际并不理想。 　　笔者通过对迅雷提供的组件（ThunderAgent）的研究，开发了一个B/S程序，实现客户端提交链接，服务端调用迅雷下载，实现对迅雷带宽占用的统一管理。
金文二级VB从入门到精通教程下载地址共330集
前20集试看下载地址: http://images.enet.com.cn/eschool/21_vb/001.wmv http://images.enet.com.cn/eschool/21_vb/002.wmv http://images.enet.com.cn/eschool/21_vb/003.wmv http://images.enet.com.cn/eschool/21_vb/004.wmv http://images.enet.com.cn/eschool/21_vb/005.wmv http://images.enet.com.cn/eschool/21_vb/006.wmv http://images.enet.com.cn/eschool/21_vb/007.wmv http://images.enet.com.cn/eschool/21_vb/008.wmv http://images.enet.com.cn/eschool/21_vb/009.wmv http://images.enet.com.cn/eschool/21_vb/010.wmv http://images.enet.com.cn/eschool/21_vb/011.wmv http://images.enet.com.cn/eschool/21_vb/012.wmv http://images.enet.com.cn/eschool/21_vb/013.wmv http://images.enet.com.cn/eschool/21_vb/014.wmv http://images.enet.com.cn/eschool/21_vb/015.wmv http://images.enet.com.cn/eschool/21_vb/016.wmv http://images.enet.com.cn/eschool/21_vb/017.wmv http://images.enet.com.cn/eschool/21_vb/018.wmv http://images.enet.com.cn/eschool/21_vb/019.wmv http://images.enet.com.cn/eschool/21_vb/020.wmv
网络编程

1,502

社区成员

18,432

社区内容

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

加载中

查看更多榜单
社区公告
暂无公告

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

+ 用AI写文章