frmmain.frm

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

        Do While bCancel = False
            DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
            '根据ListBox中的链接继续下载
            If ContinueGet() = False Then
                '下载完毕，退出
                cmdStart(0).Enabled = True
                cmdStart(1).Enabled = False
                cmdStart(2).Enabled = True
                Exit Sub
            End If
        Loop
    Else
        MsgBox "地址出错，无法开始下载"
        cmdStart(0).Enabled = True
        cmdStart(1).Enabled = False
        cmdStart(2).Enabled = True
    End If
ElseIf Index = 1 Then
    If cmdStart(1).Caption = "停止下载" Then
        '设置取消下载的标志
        bCancel = True
        cmdStart(1).Enabled = False
        cmdStart(1).Caption = "继续下载"
        '写入日志文件
    Else
        '继续下载
        bCancel = False
        cmdStart(0).Enabled = False
        cmdStart(2).Enabled = False
        cmdStart(1).Caption = "停止下载"
        cmdStart(1).Enabled = True
        While bCancel = False
            DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
            If ContinueGet() = False Then
                cmdStart(0).Enabled = True
                cmdStart(1).Enabled = False
                cmdStart(2).Enabled = True
                Exit Sub
            End If
        Wend
    End If
Else
    CDlg.Filter = "*.web"
    CDlg.FileName = "*.web"
    CDlg.ShowOpen
    '选择下载信息文件开始下载
    If Right(CDlg.FileName, 4) <> ".web" Then GoTo err1
    lstReferences.Clear
    lstImages.Clear
    LView.ListItems.Clear
    ReadNum = 0
    SaveFileName = CDlg.FileName
    If ReadDownInfo(CDlg.FileName) = True Then
        '读取保存下载信息的文件开始下载
        bCancel = False
        cmdStart(0).Enabled = False
        cmdStart(1).Caption = "停止下载"
        cmdStart(2).Enabled = False
        cmdStart(1).Enabled = True
        While bCancel = False
            DoEvents: DoEvents: DoEvents: DoEvents: DoEvents
            If ContinueGet() = False Then
                cmdStart(0).Enabled = True
                cmdStart(1).Enabled = False
                cmdStart(2).Enabled = True
                Exit Sub
            End If
        Wend
    Else
        '读取文件出错
        cmdStart(0).Enabled = True
        cmdStart(1).Enabled = False
        cmdStart(2).Enabled = True
        MsgBox "该文件不是保存下载信息的文件！"
    End If
End If
err1:
End Sub

'窗体加载事件用于初始化
Private Sub Form_Load()
'初始化类对象
objNetGet.Init
'设置显示状态信息为StatusBar的第一个Panel
objNetGet.SetStatusWindow = SBar1.Panels(1)
'lstReferences.Sorted = False
'lstImages.Sorted = False
End Sub

'该事件用于释放资源
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
objNetGet.Term
Set objNetGet = Nothing
Unload Me
End
End Sub

'该函数用于开始一个新下载起始页面
Public Function StartGet(ByVal strUrl As String) As Boolean
Dim iEndPos As Integer
strUrl = Replace(strUrl, "\", "/")
iEndPos = InStr(8, strUrl, "/")
'从下载的起始页面中取得主机名
If CBool(iEndPos) Then
    sHost = Mid$(strUrl, 1, iEndPos - 1)
Else
    sHost = Mid$(strUrl, 1, Len(strUrl))
End If
'取得相对的url资源目录名
iEndPos = InStrRev(strUrl, "/")
If CBool(iEndPos) Then
    sStartUrl = Mid$(strUrl, 1, iEndPos - 1)
Else
    sStartUrl = Mid$(strUrl, 1, Len(strUrl))
End If
'清空保存链接的集合
Set colReferences = Nothing
Set colImages = Nothing
If Len(strUrl) Then
    '开始下载起始页面
    If objNetGet.ReadUrlHtml(strUrl, SaveFilePath & "\index.htm") = True Then
        LView.ListItems.Add , , "index.htm", "html", "html"
        '从下载页面中提取链接，加入到lstReferences和lstImages中
        If objNetGet.ParseHTML("HREF=", colReferences) Then AddReferences ""
        If objNetGet.ParseHTML(" SRC=", colImages) Then AddImages ""
    Else
        '请求URL出错
        StartGet = False
        Exit Function
    End If
End If
StartGet = True
End Function

'该函数用于下载lstReferences和lstImages的URL
Public Function ContinueGet() As Boolean
Dim i As Integer
Dim sReUrl As String
bCancel = False
ContinueGet = True
'下载二进制文件：主要是图片文件
While lstImages.ListCount > 0 And bCancel = False
    sReUrl = lstImages.List(0)
    '如果链接文件中已经包含了起始的url目录，取得相对url
    If InStr(1, sReUrl, sStartUrl) = 1 Then
        sReUrl = Mid(sReUrl, Len(sStartUrl) + 1)
    End If
    '排除不在起始url目录的链接，判别是否文件已经下载
    If InStr(1, sReUrl, "http://") = 0 And FileIsGet(sReUrl) = False Then
        '检查是否存在存储文件的目录
        CheckDir "\" & sReUrl
        '下载二进制文件
        If objNetGet.ReadUrlImg(sStartUrl & "/" & sReUrl, SaveFilePath & "\" & sReUrl) = True Then
            '下载成功，加入到listview中，下载文件记数+1
            LView.ListItems.Add , , sReUrl, "img", "img"
            ReadNum = ReadNum + 1
            SBar1.Panels(2).Text = "已读取文件 " & ReadNum & " 个"
        End If
    End If
    '清除链接
    lstImages.RemoveItem (0)
    DoEvents
Wend
If lstReferences.ListCount > 0 And bCancel = False Then
    sReUrl = lstReferences.List(0)
    '如果链接文件中已经包含了起始的url目录，取得相对url
    If InStr(1, sReUrl, sStartUrl) = 1 Then
        sReUrl = Mid(sReUrl, Len(sStartUrl) + 1)
    End If
    '排除不在起始url目录的链接，判别是否文件已经下载
    If InStr(1, sReUrl, "http://") = 0 And FileIsGet(sReUrl) = False Then
        '检查是否存在存储文件的目录
        CheckDir "\" & sReUrl
        '下载文本的html文件
        If objNetGet.ReadUrlHtml(sStartUrl & "/" & sReUrl, SaveFilePath & "\" & sReUrl) = True Then
            '下载成功，加入到listview中，下载文件记数+1
            LView.ListItems.Add , , sReUrl, "html", "html"
            ReadNum = ReadNum + 1
            SBar1.Panels(2).Text = "已读取文件  " & ReadNum & " 个"
            '清空存储链接的集合
            Set colReferences = Nothing
            Set colImages = Nothing
            '从下载的页面中提取链接，加入到两个ListBox中
            If objNetGet.ParseHTML("HREF=", colReferences) Then
                AddReferences sReUrl
            End If
            If objNetGet.ParseHTML(" SRC=", colImages) Then
                AddImages sReUrl
            End If
        End If
    End If
    DoEvents
    If lstReferences.ListCount > 0 Then
        '清除LstReferences中的链接
        lstReferences.RemoveItem (0)
    End If
    DoEvents
Else
    '下载完成，返回False
    ContinueGet = False
End If
If bCancel = True Or ContinueGet = False Then
    SaveDownInfo
    cmdStart(0).Enabled = True
    cmdStart(1).Enabled = True
    cmdStart(2).Enabled = True
End If
End Function

'该过程将集合colReferences中加入相应的listBox中
Private Sub AddReferences(sReUrl As String)
Dim tStr As String
Dim Pos1 As Integer
'取得链接所在的html页面的Url目录
tStr = ""
Pos1 = InStrRev(sReUrl, "/")
If Pos1 > 0 Then
    tStr = Left(sReUrl, Pos1)
End If
For Each vReference In colReferences
    If Len(vReference) > 4 And (UCase(Right(vReference, 4)) = ".EXE" Or UCase(Right(vReference, 5)) = ".ZIP" _
        Or UCase(Right(vReference, 4)) = ".JPG" Or UCase(Right(vReference, 4)) = ".GIF") Then
        '二进制文件加入到lstImages中
        lstImages.AddItem tStr & vReference
    ElseIf Len(vReference) > 4 And (UCase(Right(vReference, 4)) = ".HTM" Or UCase(Right(vReference, 5)) = ".HTML") Then
        '文本文件加入到lstReferences中
        lstReferences.AddItem tStr & vReference, lstReferences.ListCount
    End If
Next vReference
End Sub

'该过程用于将集合colImages加入到相应的ListBox中
Private Sub AddImages(sReUrl As String)
Dim tStr As String
Dim Pos1 As Integer
tStr = ""
'取得链接所在的html页面的Url目录
Pos1 = InStrRev(sReUrl, "/")
If Pos1 > 0 Then
    tStr = Left(sReUrl, Pos1)
End If
For Each vReference In colImages
    If Len(vReference) > 4 And (UCase(Right(vReference, 4)) = ".EXE" Or UCase(Right(vReference, 5)) = ".ZIP" _
        Or UCase(Right(vReference, 4)) = ".JPG" Or UCase(Right(vReference, 4)) = ".GIF") Then
        '二进制文件加入到lstImages中
        lstImages.AddItem tStr & vReference
    ElseIf Len(vReference) > 4 And (UCase(Right(vReference, 4)) = ".HTM" Or UCase(Right(vReference, 5)) = ".HTML") Then
        '文本文件加入到lstReferences中
        lstReferences.AddItem tStr & vReference
    End If
Next vReference
End Sub

'该过程用于检查保存文件的目录是否存在，如不存在，创建该目录
Function CheckDir(sFName As String) As Boolean
On Error Resume Next
Dim tStr, tStr2 As String
Dim Pos1 As Integer
tStr = Replace(sFName, "/", "\")
tStr2 = tStr
Pos1 = InStr(1, tStr2, "\")
While Pos1 > 0
    tStr = Left(tStr2, Pos1 - 1)
    If Dir(SaveFilePath & tStr, vbDirectory) = "" Then
        '目录不存在，创建目录
        MkDir (SaveFilePath & tStr)
    End If
    Pos1 = InStr(Pos1 + 1, tStr2, "\")
Wend
End Function

'该函数用于检查要下载的文件是否存在
Private Function FileIsGet(ByVal sFile As String) As Boolean
On Error Resume Next
If Len(sFile) > 0 And Dir(SaveFilePath & "\" & sFile) <> "" Then
    '文件已下载，函数返回true
    FileIsGet = True
Else
    '文件未下载，函数返回false
    FileIsGet = False
End If
End Function

'该函数用于保存下载信息
Private Function SaveDownInfo() As Boolean
Dim i As Long
Dim iFnum As Integer
iFnum = FreeFile()
Open SaveFileName For Output As #iFnum
'写入标识文件的字符串
Print #iFnum, "WEBDOWN INFORMATION"
'写入存盘路径
Print #iFnum, "[SaveFilePath]"
Print #iFnum, SaveFilePath
'写入下载起始地址
Print #iFnum, "[StartUrl]"
Print #iFnum, sStartUrl
'写入未下载的html文件
Print #iFnum, "[HTML]"
For i = 0 To lstReferences.ListCount - 1
    Print #iFnum, lstReferences.List(i)
Next i
'写入未下载的二进制文件
Print #iFnum, "[IMAGE]"
For i = 0 To lstImages.ListCount - 1
    Print #iFnum, lstImages.List(i)
Next i
'写入已经下载的文件
Print #iFnum, "[DOWNED]"
For i = 1 To LView.ListItems.Count
    Print #iFnum, LView.ListItems(i).Text
Next i
Close iFnum
End Function

'该函数用于读取下载信息文件以恢复下载设置
Private Function ReadDownInfo(sFName As String) As Boolean
Dim i As Long
Dim iFnum As Integer
Dim LineStr As String
Dim ActionStr As String
iFnum = FreeFile()
Open sFName For Input As #iFnum
'判断是否下载的信息文件
Line Input #iFnum, LineStr
If LineStr <> "WEBDOWN INFORMATION" Then
    ReadDownInfo = False
    Close iFnum
    Exit Function
End If
Do While Not EOF(iFnum)
Line Input #iFnum, LineStr
If LineStr = "[SaveFilePath]" Or LineStr = "[StartUrl]" Or LineStr = "[HTML]" Or _
    LineStr = "[IMAGE]" Or LineStr = "[DOWNED]" Then
    ActionStr = LineStr
Else
    Select Case ActionStr
        Case "[SaveFilePath]"
            '保存下载文件路径
            SaveFilePath = LineStr
        Case "[StartUrl]"
            '起始URL
            sStartUrl = LineStr
        Case "[HTML]"
            '未下载的HTML文件链接
            lstReferences.AddItem LineStr
        Case "[IMAGE]"
            '未下载的二进制文件链接
            lstImages.AddItem LineStr
        Case "[DOWNED]"
            '已下载的文件
            If LCase(Right(LineStr, 4)) = ".htm" Or LCase(Right(LineStr, 5)) = ".html" Then
                LView.ListItems.Add , , LineStr, "html", "html"
            Else
                LView.ListItems.Add , , LineStr, "img", "img"
            End If
    End Select
End If
Loop
Close iFnum
'显示下载信息
ReadNum = LView.ListItems.Count
txtInfo.Text = "下载起始URL：" & sStartUrl & vbCrLf
txtInfo.Text = txtInfo.Text & "保存路径：   " & SaveFilePath & vbCrLf
txtInfo.Text = txtInfo.Text & "信息文件：   " & sFName & vbCrLf
txtInfo.Text = txtInfo.Text & "下载文件类型：*.EXE *.HTM *.HTML *.ZIP *.GIF * JPG"
ReadDownInfo = True
End Function