1,502
社区成员




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
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
运行示例:
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来实现这些功能;