frmdown.frm

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

            Key             =   "open"
         EndProperty
         BeginProperty ListImage9 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmDown.frx":27B0
            Key             =   "stop"
         EndProperty
      EndProperty
   End
   Begin VB.Menu menufile 
      Caption         =   "文件"
      Begin VB.Menu menuadd 
         Caption         =   "加入新任务"
      End
      Begin VB.Menu menuquit 
         Caption         =   "退出"
      End
   End
   Begin VB.Menu menusetup 
      Caption         =   "设置"
      Begin VB.Menu menuDel 
         Caption         =   "删除"
      End
   End
End
Attribute VB_Name = "frmDown"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim Xitem As ListItem
Dim mDownInfoSave As DownInfoSave

'声明正在下载的任务的类变量
Dim DownJet(MaxDown) As clsDown

Private Sub add_Click()
frmAdd.Show vbModal
End Sub

Private Sub Form_Load()
Dim i As Integer
CDlg.FileName = App.Path & "\TEMP"
'创建两个类对象，每个对象负责一个下载任务
For i = 1 To MaxDown
    Set DownJet(i) = New clsDown
Next i
'初始化ListView控件
LView.ColumnHeaders.Clear
LView.ColumnHeaders.Add , , "URL地址", LView.Width - 240 * Screen.TwipsPerPixelX
LView.ColumnHeaders.Add , , "大小", 80 * Screen.TwipsPerPixelX
LView.ColumnHeaders.Add , , "已下载大小", 80 * Screen.TwipsPerPixelX
LView.ColumnHeaders.Add , , "时间", 80 * Screen.TwipsPerPixelX
'从数据文件中读取下载任务的信息，加入到ListView中
Dim Fnum As Integer
Dim mFname As String
'保存下载任务信息的文件
mFname = App.Path & "\Downjet.djt"
Fnum = FreeFile
Open mFname For Random As #Fnum Len = Len(mDownInfoSave)
i = 1
While Not EOF(Fnum)
    ReDim Preserve mDownInfo(i)
    Get #Fnum, i, mDownInfoSave
    If Not EOF(Fnum) Then
        mDownInfo(i).mFile = Trim(mDownInfoSave.mFile)
        mDownInfo(i).mGetSize = mDownInfoSave.mGetSize
        mDownInfo(i).mIndex = mDownInfoSave.mIndex
        mDownInfo(i).mProxy = Trim(mDownInfoSave.mProxy)
        mDownInfo(i).mAuthId = Trim(mDownInfoSave.mAuthId)
        mDownInfo(i).mAuthPass = Trim(mDownInfoSave.mAuthPass)
        mDownInfo(i).mProxyPort = mDownInfoSave.mProxyPort
        mDownInfo(i).mSize = mDownInfoSave.mSize
        mDownInfo(i).mUrl = Trim(mDownInfoSave.mUrl)
        mDownInfo(i).mUseProxy = mDownInfoSave.mUseProxy
        If mDownInfo(i).mGetSize <> mDownInfo(i).mSize Then
            If Dir(mDownInfo(i).mFile) <> "" And mDownInfo(i).mFile <> "" Then
                mDownInfo(i).mGetSize = FileLen(mDownInfo(i).mFile)
            Else
                mDownInfo(i).mGetSize = 0
            End If
        End If
        AddUrl mDownInfo(i).mUrl, mDownInfo(i).mSize, mDownInfo(i).mGetSize, mDownInfo(i).mFile
        i = i + 1
    End If
Wend
Close Fnum
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim i As Integer, j As Integer
Dim Fnum As Integer
Dim mFname As String
'往文件DownJet.djt中保存在ListView中的下载任务
mFname = App.Path & "\Downjet.djt"
If Dir(mFname) <> "" Then
    Kill mFname
End If
Fnum = FreeFile
j = 1
Open mFname For Random As #Fnum Len = Len(mDownInfoSave)
For i = 1 To UBound(mDownInfo) - 1
    If mDownInfo(i).mUrl <> "" And LView.ListItems(i).SmallIcon <> "delete" Then
        mDownInfoSave.mFile = mDownInfo(i).mFile
        mDownInfoSave.mGetSize = mDownInfo(i).mGetSize
        mDownInfoSave.mIndex = mDownInfo(i).mIndex
        mDownInfoSave.mProxy = mDownInfo(i).mProxy
        mDownInfoSave.mAuthId = mDownInfo(i).mAuthId
        mDownInfoSave.mAuthPass = mDownInfo(i).mAuthPass
        mDownInfoSave.mProxyPort = mDownInfo(i).mProxyPort
        mDownInfoSave.mSize = mDownInfo(i).mSize
        mDownInfoSave.mUrl = mDownInfo(i).mUrl
        mDownInfoSave.mUseProxy = mDownInfo(i).mUseProxy
        Put #Fnum, j, mDownInfoSave
        j = j + 1
    End If
Next i
Close Fnum
End
End Sub

Private Sub LView_DblClick()
'如果选中的任务处于下载状态则停止，否则开始下载
Dim i As Integer
Dim mSel2 As Integer
mSel2 = LView.SelectedItem.Index
'如果选中的已经下载完毕，显示下载完毕提示
If mDownInfo(mSel2).mGetSize = mDownInfo(mSel2).mSize And mDownInfo(mSel2).mSize > 0 Then
    lblTishi.Caption = mDownInfo(mSel2).mFile & "已经下载完毕！！！"
    txtInfo.Text = txtInfo.Text & lblTishi.Caption & vbCrLf
    Exit Sub
End If
'如果正在下载，提示并退出该过程
If LView.SelectedItem.SmallIcon = "start" Then
    lblTishi.Caption = "取消下载" & mDownInfo(mSel2).mUrl
    For i = 1 To MaxDown
        If DownJet(i).WhichDown = mSel2 Then
            DownJet(i).bCancel = True
            Exit For
        End If
    Next i
    Exit Sub
End If

'检查是否有空闲的下载线程
For i = 1 To MaxDown
    If DownJet(i).bBusy = False Then
        Set DownJet(i) = Nothing
        Set DownJet(i) = New clsDown
        mSel2 = LView.SelectedItem.Index
        DownJet(i).DownUrl = LView.SelectedItem.Text
        '分析下载的Url是否合法
        If DownJet(i).AnalyzeUrl = False Then
            Exit Sub
        End If
        '如果第一次下载，选择路径保存下载文件
        If mDownInfo(mSel2).mFile = "" Then
            '如果取消保存则退出该过程，取消下载
            On Error GoTo err1
            CDlg.CancelError = True
            CDlg.Flags = cdlOFNOverwritePrompt
            CDlg.FileName = DownJet(i).mFile
            CDlg.ShowSave
            DownJet(i).mFile = CDlg.FileName
            mDownInfo(mSel2).mFile = DownJet(i).mFile
        Else
            DownJet(i).mFile = mDownInfo(mSel2).mFile
        End If
        DownJet(i).bBusy = True
        '下载任务索引
        DownJet(i).WhichDown = mSel2
        '下载的文件总长度
        DownJet(i).mFlen = mDownInfo(mSel2).mSize
        '已经下载的文件的大小
        DownJet(i).ReceiveBytes = mDownInfo(mSel2).mGetSize
        '****设置代理服务器选项
        DownJet(i).mProxy = mDownInfo(mSel2).mProxy
        DownJet(i).mProxyPort = mDownInfo(mSel2).mProxyPort
        DownJet(i).mAuthId = mDownInfo(mSel2).mAuthId
        DownJet(i).mAuthPass = mDownInfo(mSel2).mAuthPass
        '****
        '开始下载
        DownJet(i).StartDown
        Exit For
    End If
Next i
err1:
End Sub

'向ListView添加Item的过程
Public Sub AddUrl(myUrl As String, Optional ByVal mSize As String, Optional ByVal mGetSize As String, Optional ByVal mFile As String)
If myUrl <> "" Then
    If Val(mGetSize) + 1 < Val(mSize) Or Val(mSize) = 0 Then
        Set Xitem = LView.ListItems.Add(, "", myUrl, "stop", "stop")
    Else
        Set Xitem = LView.ListItems.Add(, "", myUrl, "ok", "ok")
    End If
    Xitem.Tag = mFile
    Xitem.ListSubItems.Add , "size", mSize
    Xitem.ListSubItems.Add , "getsize", mGetSize
End If
End Sub

Private Sub LView_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Static mIndex As Integer
Dim SelectDown As Integer
SelectDown = LView.SelectedItem.Index
If SelectDown < 1 Then Exit Sub
'在txtfile中显示选中的下载任务信息
txtFile.Text = "URL:         " & mDownInfo(SelectDown).mUrl & vbCrLf
txtFile.Text = txtFile.Text & "文件名:      " & mDownInfo(SelectDown).mFile & vbCrLf
txtFile.Text = txtFile.Text & "大小:        " & mDownInfo(SelectDown).mSize & "字节" & vbCrLf
txtFile.Text = txtFile.Text & "已下载大小:  " & mDownInfo(SelectDown).mGetSize & "字节" & vbCrLf
txtFile.Text = txtFile.Text & "代理服务器:  " & mDownInfo(SelectDown).mProxy & vbCrLf
'在picturebox控件中显示当前选中的下载任务的block信息
Pic(0).Cls
DrawDownPic 0, 0, mDownInfo(SelectDown).mSize, mDownInfo(SelectDown).mGetSize
'如果按了鼠标右键弹出删除菜单
If Button = 2 Then
    PopupMenu menusetup
End If
End Sub

'接收拖放的信息，如果是可下载的Url，加到ListView中
Private Sub LView_OLEDragDrop(Data As MSComctlLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single)
If Data.GetFormat(vbCFText) Then
    If vbOK = MsgBox("确定要下载" & Data.GetData(vbCFText), vbOKCancel) Then
        AddNewUrl Data.GetData(vbCFText)
    End If
End If
End Sub

Private Sub menuadd_Click()
'加入下载任务
frmAdd.Show vbModal
End Sub

Private Sub menuDel_Click()
'删除下载任务
LView.ListItems(LView.SelectedItem.Index).SmallIcon = "delete"
End Sub

Private Sub menuquit_Click()
'退出程序
Unload Me
End Sub

'根据接收到的文件长度，已经下载长度的信息在Pic画Block图
'mflen：文件长度
'mNum：接收到的字节数
'ReceiveBytes：已经接收到的字节数
Public Sub DrawDownPic(Index As Integer, mNum As Long, Optional mFlen As Long, Optional ReceiveBytes As Long)
Dim Getnum As Long
Getnum = ReceiveBytes
Dim TGetNum As Long
Dim i, j As Long
Dim kk1 As Long, kk2 As Long
If mNum = 0 Then
    Getnum = 0
End If
If Getnum = 0 Then
    Pic(0).FillColor = vbWhite
    kk1 = mFlen / 4096
    j = 0
    For i = 1 To mFlen / 4096
        Pic(0).Circle ((i - j * 50) * 120 + 0, j * 120 + 100), 50, vbBlack
        j = Fix(i / 50)
    Next i
    Pic(0).FillColor = &HFF0000
End If
TGetNum = Getnum
If Getnum = 0 And ReceiveBytes > 0 Then
    '加上以前已经接收到的
    Getnum = ReceiveBytes
End If
Getnum = Getnum + mNum
kk1 = Fix(TGetNum / 4096)
kk2 = Fix(Getnum / 4096)
j = Fix(kk1 / 50) + 1
For i = kk1 To kk2
    Pic(0).Circle ((i - j * 50) * 120 + 0, j * 120 + 100), 50, vbRed
    j = Fix(i / 50)
Next i
End Sub

'加入新的下载任务
Public Function AddNewUrl(myUrl As String)
    Dim i As Integer
    For i = 1 To LView.ListItems.Count
        If LView.ListItems(i).Text = myUrl Then
            MsgBox "该URL已经在下载队列中了！"
            Exit Function
        End If
    Next i
    AddUrl myUrl
    Dim kk As Integer
    kk = UBound(mDownInfo)
    ReDim Preserve mDownInfo(kk + 1)
    mDownInfo(kk).mUrl = myUrl
End Function