clsdown.cls

本书源码主要针对目前流行的FTP、HTTP、E-mail、Telnet、ICMP、Modem串口通信编程、拨号网络编程等内容进行详细的讲解

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsDown"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Option Explicit

Public bBusy As Boolean         '表示正在下载一个任务
Public DownUrl As String            '要下载的url地址
Public WhichDown As Integer     '下载任务的索引
Public StartTime As Date            '下载的开始连接时间
Public ReceiveBytes As Long     '已下载的文件数据字节数
Public mFlen As String              '下载文件长度
Public bCancel As Boolean           '用户是否取消下载
Public mProxy As String         '代理服务器地址和端口
Public mProxyPort As Integer
Public mAuthId As String            '认证帐号及密码
Public mAuthPass As String
Public mFile As String              '保存的文件路径
Private mHost As String              '连接的主机名和端口
Private mPort As Integer
Private mRelativeUrl As String      '下载的相对URL
Private sStatusCode As String       '服务器响应码
Private hInternetSession As Long        'InternetOpen打开的句柄
Private hInternetConnect As Long        'InternetConnect打开的句柄
Private hHttpOpenRequest As Long    'HttpOpenRequest打开的句柄

'该过程用于取得响应得标题字段信息
Private Function GetQueryInfo(ByVal hHttpRequest As Long, sReContent As String, ByVal iInfoLevel As Long) As Boolean
Dim sBuffer         As String * 1024
Dim lBufferLength   As Long
lBufferLength = Len(sBuffer)
GetQueryInfo = CBool(HttpQueryInfo(hHttpRequest, iInfoLevel, ByVal sBuffer, lBufferLength, 0))
sReContent = Mid(sBuffer, 1, lBufferLength)
End Function


'分析下载的URL
Public Function AnalyzeUrl() As Boolean
Dim pos1, pos2 As Integer
Dim mUrl As String
mUrl = DownUrl
If InStr(1, mUrl, "http://") > 0 Then
    '得到端口号
    mPort = INTERNET_DEFAULT_HTTP_PORT
Else
    AnalyzeUrl = False
    Exit Function
End If
pos1 = InStr(1, mUrl, "http://")
pos2 = InStr(8, mUrl, "/")
If pos2 = 0 Then
    AnalyzeUrl = False
    Exit Function
Else
    '得到主机地址
    mHost = Mid(mUrl, 8, pos2 - 8)
    pos1 = InStr(1, mHost, ":")
    If pos1 > 0 Then
        mPort = Mid(mHost, pos1 + 1)
        mHost = Mid(mHost, 1, pos1 - 1)
    End If
    '得到相对路径
    mRelativeUrl = Mid(mUrl, pos2)
End If
pos2 = InStrRev(mUrl, "/")
If pos2 > 8 Then
    '得到文件名
    mFile = Mid(mUrl, pos2 + 1)
Else
    AnalyzeUrl = False
    Exit Function
End If
AnalyzeUrl = True
End Function

'调用该函数下载文件
Public Function StartDown() As Boolean
bBusy = True
SetStatus "开始下载"
'打开Internet会话句柄
hInternetSession = InternetOpen(scUserAgent, INTERNET_OPEN_TYPE_PRECONFIG, vbNullString, vbNullString, 0)
If CBool(hInternetSession) Then
    SetStatus "InternetOpen打开成功！！"
Else
    SetStatus "InternetOpen失败!"
End If
StartDown = StartDownFile()
'无论下载成功，都关闭所有的Internet函数打开的句柄
InternetCloseHandle hInternetSession
InternetCloseHandle hInternetConnect
InternetCloseHandle hHttpOpenRequest
bBusy = False
End Function

'直接连接Url指定的服务器下载
Public Function StartDownFile() As Boolean
Dim iRetVal     As Integer
Dim vDllVersion As tWinInetDLLVersion
Dim sStatus     As String
SetStatus "正在打开Internet连接"
If mAuthId = "" Then
    hInternetConnect = InternetConnect(hInternetSession, mHost, mPort, _
                            vbNullString, vbNullString, INTERNET_SERVICE_HTTP, 0, 0)
Else
    hInternetConnect = InternetConnect(hInternetSession, mHost, mPort, _
                            mAuthId, mAuthPass, INTERNET_SERVICE_HTTP, 0, 0)
End If
If hInternetConnect > 0 Then
    SetStatus "HttpOpenRequest"
    '打开请求mRelativeUrl
    hHttpOpenRequest = HttpOpenRequest(hInternetConnect, "GET", mRelativeUrl, "HTTP/1.0", vbNullString, 0, _
         INTERNET_FLAG_RELOAD, 0)
    If CBool(hHttpOpenRequest) Then
        '加入请求的标题字段
        Dim Getstr As String
        Getstr = "Accept: */*"
        HttpAddRequestHeaders hHttpOpenRequest, Getstr, Len(Getstr), HTTP_ADDREQ_FLAG_ADD
        Getstr = "User-Agent: DownJet1.0"
        HttpAddRequestHeaders hHttpOpenRequest, Getstr, Len(Getstr), HTTP_ADDREQ_FLAG_ADD
        Getstr = "Host: " & mHost
        HttpAddRequestHeaders hHttpOpenRequest, Getstr, Len(Getstr), HTTP_ADDREQ_FLAG_ADD
        If ReceiveBytes > 0 Then
            '如果以前已经下载了一部分数据，发送断点续传请求
            Getstr = "Range: bytes=" & ReceiveBytes & "-"
            HttpAddRequestHeaders hHttpOpenRequest, Getstr, Len(Getstr), HTTP_ADDREQ_FLAG_ADD
        End If
'        If mAuthId <> "" Then
'            Getstr = "Authorization: Basic " & EncodeStr(mAuthId & ":" & mAuthPass)
'            HttpAddRequestHeaders hHttpOpenRequest, Getstr, Len(Getstr), HTTP_ADDREQ_FLAG_ADD
'        End If
        Getstr = "Connection: close"
        HttpAddRequestHeaders hHttpOpenRequest, Getstr, Len(Getstr), HTTP_ADDREQ_FLAG_ADD
        SetStatus "发送请求"
        '向服务器发送下载文件请求
        iRetVal = HttpSendRequest(hHttpOpenRequest, vbNullString, 0, 0, 0)
        If iRetVal Then
            SetStatus "HttpQueryInfo"
            '取得服务器返回的数据长度
            GetQueryInfo hHttpOpenRequest, mFlen, HTTP_QUERY_CONTENT_LENGTH
            '取得服务器返回的响应码
            GetQueryInfo hHttpOpenRequest, sStatusCode, HTTP_QUERY_STATUS_CODE
            sStatus = "请求完毕"
        Else
            sStatus = "HttpSendRequest失败"
        End If
    Else
        sStatus = "HttpOpenRequest失败"
    End If
Else
    sStatus = "InternetConnect失败"
End If
SetStatus sStatus
If sStatusCode = "200" Or sStatusCode = "206" Then
    '根据响应码判断请求结果
    SaveData
Else
    SetStatus sStatusCode & "请求失败"
End If
StartDownFile = True
End Function

'该函数用于读取和保存请求文件的数据
Public Function SaveData() As Boolean
Dim sReadBuffer(2048)   As Byte     '为InternetReadFile函数提供字符串作为数据接收缓冲区
Dim lNumberOfBytesRead  As Long     '调用InternetReadFile函数读取的字节数
Dim lTotalBytesRead     As Long       '一共读取的字节数
Dim bDoLoop             As Boolean    '调用InternetReadFile的返回值
Dim i                   As Integer
On Error GoTo errReadUrl
SetStatus "正在读取数据 "
If Len(mFile) = 0 Then
    SaveData = False
    Exit Function
End If
'判断打开的HttpOpenRequest句柄是否有效
If CBool(hHttpOpenRequest) Then
        bDoLoop = True
    Dim iFileNum As Integer
    While bDoLoop And bCancel = False
        DoEvents: DoEvents: DoEvents
        '读取缓冲区的数据
        bDoLoop = InternetReadImg(hHttpOpenRequest, sReadBuffer(0), 2048, lNumberOfBytesRead)
        If Not CBool(bDoLoop) Then Exit Function
        lTotalBytesRead = lTotalBytesRead + lNumberOfBytesRead
        If CBool(lNumberOfBytesRead) Then
            If iFileNum = 0 Then
                SetStatus "Reading Url:开始下载数据"
                iFileNum = FreeFile
                Open CStr(mFile) For Binary As iFileNum
                Seek #iFileNum, ReceiveBytes + 1
            End If
            '保存数据
            For i = 0 To lNumberOfBytesRead - 1
                Put #iFileNum, , sReadBuffer(i)
            Next i
            SetStatus "接收字节", lNumberOfBytesRead
            ReceiveBytes = ReceiveBytes + lNumberOfBytesRead
        Else
            bDoLoop = False
        End If
    Wend
    InternetCloseHandle (hHttpOpenRequest)
    If iFileNum <> 0 Then
        Close (iFileNum)
        SaveData = True
    Else
        SaveData = False
    End If
Else
    SetStatus "下载过程中出错了"
    Exit Function
End If
If bCancel = False Then
    SetStatus "数据读取完毕"
Else
    SetStatus "取消下载"
End If
Exit Function
errReadUrl:
    SetStatus "下载过程中出错了"
End Function

'用于根据状态字符串进行相应的操作
Sub SetStatus(sStatus As String, Optional lReadNum As Long)
If lReadNum = 0 Then
    '如果没有读取字节数的参数，显示信息
    frmDown.txtInfo.Text = frmDown.txtInfo.Text & sStatus & DownUrl & vbCrLf
Else
    '记录下载文件的信息
    mDownInfo(WhichDown).mGetSize = ReceiveBytes + lReadNum
    If mDownInfo(WhichDown).mSize = 0 Then
        mDownInfo(WhichDown).mSize = mFlen
        frmDown.LView.ListItems(WhichDown).SubItems(1) = mFlen
    End If
    frmDown.LView.ListItems(WhichDown).SubItems(2) = ReceiveBytes + lReadNum
    If WhichDown = frmDown.LView.SelectedItem.Index Then
        '如果当前下载的是在LView选中的任务，画下载情况图
        frmDown.DrawDownPic WhichDown, lReadNum, CLng(mFlen), ReceiveBytes
    End If
End If
'设置Lview中的SmallIcon
If InStr(1, sStatus, "数据读取完毕") > 0 Then
        frmDown.LView.SelectedItem.SmallIcon = "ok"
ElseIf InStr(1, sStatus, "取消下载") > 0 Or InStr(1, sStatus, "下载过程中出错了") > 0 Or InStr(1, sStatus, "请求失败") > 0 Then
        frmDown.LView.SelectedItem.SmallIcon = "stop"
ElseIf InStr(1, sStatus, "开始下载") > 0 Then
        frmDown.LView.SelectedItem.SmallIcon = "start"
End If
DoEvents: DoEvents
End Sub