frmmain.frm

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

End Sub

Sub SizeControls(x As Single)
'该程序是调整每个控件的相对位置
    On Error Resume Next

    If x < 1500 Then x = 1500
    If x > (Me.Width - 1500) Then x = Me.Width - 1500
    tvTreeView.Width = x
    imgSplitter.Left = x
    lvListView.Left = x + 40
    picTitle.Left = x + 40
    lvListView.Width = Me.Width - (tvTreeView.Width + 140)
    picTitle.Width = lvListView.Width - 20
    imgIcon.Left = picTitle.Width - imgIcon.Width - 40
    ProgressBar1.Width = picTitle.Width - ProgressBar1.Left - imgIcon.Width - 120
    Picture1.Left = ProgressBar1.Left + (ProgressBar1.Width - Picture1.Width)


  
    If CoolBar1.Visible Then
        tvTreeView.Top = CoolBar1.Height + 40
    Else
        tvTreeView.Top = 0
    End If
    
    picTitle.Top = tvTreeView.Top
    lvListView.Top = picTitle.Top + picTitle.Height
    
    If sbStatusBar.Visible Then
        tvTreeView.Height = Me.ScaleHeight - (IIf(CoolBar1.Visible, CoolBar1.Height, 0) + sbStatusBar.Height) - 40 - txtMessages.Height
    Else
        tvTreeView.Height = Me.ScaleHeight - IIf(CoolBar1.Visible, CoolBar1.Height, 0) - 40 - txtMessages.Height
    End If

    lvListView.Height = tvTreeView.Height - picTitle.Height
    imgSplitter.Top = tvTreeView.Top
    imgSplitter.Height = tvTreeView.Height
    
    txtMessages.Top = tvTreeView.Top + tvTreeView.Height + 40
    txtMessages.Height = 1455 - 40
    txtMessages.Width = Me.ScaleWidth
    
    LockWindowUpdate 0
    
End Sub


Private Sub m_FtpConnection_DownloadProgress(lBytes As Long)
'下载文件进程事件，获得已经下载了多少字节
    On Error Resume Next

    sbStatusBar.Panels(1).Text = "Downloading " & m_strFile & " (" & lBytes & " bytes)"
    ProgressBar1.Value = lBytes / (m_lFileSize / 100)

End Sub

Private Sub m_FtpConnection_ReplyMessage(ByVal sMessage As String)
'显示一些操作信息，比如系统正在干什么
    txtMessages = txtMessages & sMessage
    txtMessages.SelStart = Len(txtMessages)
End Sub

Private Sub m_FtpConnection_StateChanged(State As FTP_CONNECTION_STATES)
'显示连接服务器的一些状态
    Dim strStatus As String
    
    Select Case State
        Case FTP_CONNECTION_RESOLVING_HOST
            strStatus = "Resolving host..."
        Case FTP_CONNECTION_HOST_RESOLVED
            strStatus = "Host resolved"
        Case FTP_CONNECTION_CONNECTED
            strStatus = "Connected"
        Case FTP_CONNECTION_AUTHENTICATION
            strStatus = "Authentication..."
        Case FTP_USER_LOGGED
            strStatus = "You are logged in. Connection ready."
        Case FTP_ESTABLISHING_DATA_CONNECTION
            strStatus = "Establishing data connection..."
        Case FTP_DATA_CONNECTION_ESTABLISHED
            strStatus = "Data connection established."
        Case FTP_RETRIEVING_DIRECTORY_INFO
            strStatus = "Retrieving directory info..."
        Case FTP_DIRECTORY_INFO_COMPLETED
            strStatus = "Directory listing completed."
        Case State = FTP_TRANSFER_STARTING
            strStatus = "Transfer in progress..."
        Case FTP_TRANSFER_COMLETED
            strStatus = "Transfer completed."
            ProgressBar1.Value = 0.01
            m_lFileSize = 0
    End Select
    
    sbStatusBar.Panels(1).Text = strStatus
    
End Sub

Private Sub m_FtpConnection_UploadProgress(lBytes As Long)
'显示上载数据进程
    On Error Resume Next

    sbStatusBar.Panels(1).Text = "Uploading " & m_strFile & " (" & lBytes & " bytes)"
    ProgressBar1.Value = lBytes / (m_lFileSize / 100)

End Sub

Private Sub mnuConnect_Click()
'单击连接服务器按钮，调用EstablishConnection
    Call EstablishConnection
End Sub

Private Sub mnuCreateDir_Click()
'菜单事件，目的是创建目录
    Dim strDirName As String
    
    strDirName = InputBox("Enter directory name, please.", "Create new directory")
    If Len(strDirName) > 0 Then
        If m_FtpConnection.CreateDirectory(strDirName) Then
            ListFiles tvTreeView.SelectedItem
        Else
            MsgBox "Can't create new directory." & vbCrLf & vbCrLf & _
                    "Server response: " & _
                    m_FtpConnection.GetLastServerResponse, , _
                    "Can't create directory"
        End If
    End If
    
End Sub

Private Sub mnuDelete_Click()
'菜单事件，目的是删除目录
    Dim intRetVal   As Integer
    Dim strFileName As String
    '
    On Error GoTo ERROR_HANDLER
    
    strFileName = tvTreeView.SelectedItem.Key & lvListView.SelectedItem.Text
    '
    intRetVal = MsgBox("Do you really want to delete file " & strFileName & "?", vbYesNoCancel, "Delete file")
    '
    If intRetVal = vbYes Then
        If m_FtpConnection.DeleteFile(strFileName) Then
            ListFiles tvTreeView.SelectedItem
        Else
            MsgBox "Can't delete file." & vbCrLf & vbCrLf & _
                    "Server response: " & _
                    m_FtpConnection.GetLastServerResponse, , _
                    "Can't delete file"
        End If
    End If
    '
    Exit Sub
    '
ERROR_HANDLER:
    If Err = 91 Then
        MsgBox "Select file to rename, please.", vbInformation, "Rename File"
    Else
        MsgBox "Error occured!" & vbCrLf & "#" & Err.Number & ": " & Err.Description, _
                vbInformation, "Rename File"
    End If
    
End Sub

Private Sub mnuDownload_Click()
'菜单事件，调用下载子程序
    Call DownloadFile
End Sub

Private Sub mnuEdit_Click()
'菜单事件,根据程序目前状态设置一些菜单的enable属性
    With m_FtpConnection
        mnuRename.Enabled = Not .Busy
        mnuRemoveDir.Enabled = Not .Busy
        mnuCreateDir.Enabled = Not .Busy
        mnuDelete.Enabled = Not .Busy
    End With
    
End Sub

Private Sub mnuFile_Click()
'菜单事件,根据程序目前状态设置一些菜单的enable属性
    With m_FtpConnection
        mnuDownload.Enabled = Not .Busy
        mnuUpload.Enabled = Not .Busy
    End With
    
End Sub

Private Sub mnuHelp_Click()

    mnuHelpAbout.Enabled = Not m_FtpConnection.Busy

End Sub

Private Sub mnuListViewMode_Click(Index As Integer)
'菜单事件，设定lvlistview控件的显示模式
    Select Case Index
        Case 0
            lvListView.View = lvwIcon
        Case 1
            lvListView.View = lvwSmallIcon
        Case 2
            lvListView.View = lvwList
        Case 3
            lvListView.View = lvwReport
    End Select
    
    tbToolBar.Buttons(15 + Index).Value = tbrPressed
    
End Sub

Private Sub mnuRemoveDir_Click()
'菜单事件，表示要删除一个目录
    Dim intAnswer As Integer
    Dim CurNode As Node
    Dim i As Integer
    Dim intChildren As Integer
    
    On Error GoTo ERROR_HANDLER
    
    If Not tvTreeView.SelectedItem.Key = tvTreeView.SelectedItem.Root.Key Then
        intAnswer = MsgBox("Do you really want to remove directory: " & tvTreeView.SelectedItem.Text, vbQuestion + vbYesNo, "Remove Directory")
        If intAnswer = vbYes Then
            If m_FtpConnection.RemoveDirectory(tvTreeView.SelectedItem.Key) Then
                Set CurNode = tvTreeView.SelectedItem.Parent
                Set tvTreeView.SelectedItem = CurNode
                
                '删除选定目录下面的所有东西
                intChildren = CurNode.Children
                For i = 1 To intChildren
                    tvTreeView.Nodes.Remove CurNode.Child.Index
                Next i
                '
                ListFiles tvTreeView.SelectedItem
            Else
                MsgBox "Can't remove directory." & vbCrLf & vbCrLf & _
                        "Server response: " & _
                        m_FtpConnection.GetLastServerResponse, , _
                        "Can't remove directory"
            End If
        End If
    End If
    
    Exit Sub
    
ERROR_HANDLER:
    If Err = 91 Then
        MsgBox "Select file to rename, please.", vbInformation, "Rename File"
    Else
        MsgBox "Error occured!" & vbCrLf & "#" & Err.Number & ": " & Err.Description, _
                vbInformation, "Rename File"
    End If
    
    
End Sub

Private Sub mnuRename_Click()
'菜单事件，表示要更改一个文件名
    Dim strFileName     As String
    Dim strNewFileName  As String
    Dim intAnswer       As Integer
    
    On Error GoTo ERROR_HANDLER
    
    strFileName = lvListView.SelectedItem.Text
    
    strNewFileName = InputBox("Enter new file name for " & strFileName, "Rename File")
    '
    If Len(strNewFileName) > 0 Then
        
        intAnswer = MsgBox("Do you really want to rename file " & strFileName & " to " & strNewFileName & "?", _
                vbYesNo + vbQuestion, "Rename File")
        
        If intAnswer = vbYes Then
            If m_FtpConnection.RenameFile(strFileName, strNewFileName) Then
                ListFiles tvTreeView.SelectedItem
            Else
                MsgBox "Can't rename file." & vbCrLf & vbCrLf & _
                        "Server response: " & _
                        m_FtpConnection.GetLastServerResponse, , _
                        "Can't rename file"
            End If
        End If
        '
    End If
    '
    Exit Sub
    '
ERROR_HANDLER:
    If Err = 91 Then
        MsgBox "请选择要更名的文件, please.", vbInformation, "更改文件名"
    Else
        MsgBox "Error occured!" & vbCrLf & "#" & Err.Number & ": " & Err.Description, _
                vbInformation, "Rename File"
    End If
    
End Sub

Private Sub mnuUpload_Click()
'菜单事件，表示上载一个文件
    Dim sFile       As String
    Dim bFileExists As Boolean
    Dim strFileName As String
    Dim lvItem      As ListItem
    Dim intRetVal   As Integer
    Dim lStartPoint As Long
    
    On Error Resume Next
        
    With dlgCommonDialog
        .DialogTitle = "选择上载文件"
        .CancelError = True
        .Filter = "All Files (*.*)|*.*"
        .ShowSave
        If Err = 0 Then
            If Len(.FileName) = 0 Then
                Exit Sub
            End If
            
            strFileName = Mid$(.FileName, InStrRev(.FileName, "\") + 1)
                    
            For Each lvItem In lvListView.ListItems
                If lvItem.Text = strFileName Then
                    bFileExists = True
                    Exit For
                End If
            Next
            
            m_lFileSize = FileLen(.FileName)
            
            If bFileExists Then
                If m_lFileSize > CLng(lvItem.SubItems(1)) Then
                    retVal = MsgBox("文件 " & strFileName & " already exists!" & vbCrLf & _
                                  "远程文件大小为 - " & lvItem.SubItems(1) & " 字节" & vbCrLf & _
                                  "本地文件大小为  - " & m_lFileSize & " 字节" & vbCrLf & vbCrLf & _
                                  "你想将数据添加到远程文件吗?" & vbclf & vbCrLf & _
                                  "注意: 选择no将会产生新文件.", _
                                  vbYesNoCancel + vbQuestion, "文件已经存在")
                    If retVal = vbYes Then
                        lStartPoint = CLng(lvItem.SubItems(1))
                    ElseIf retVal = vbCancel Then
                        Exit Sub
                    End If
                Else
                    retVal = MsgBox("文件 " & strFileName & " 已经存在!" & vbCrLf & _
                                  "远程文件大小为 - " & lvItem.SubItems(1) & " 字节" & vbCrLf & _
                                  "本地文件大小为  - " & m_lFileSize & " 字节" & vbCrLf & vbCrLf & _
                                  "你要上载吗？" & vbclf & vbCrLf & _
                                  "注意: 选择no将会产生新文件.", _
                                  vbYesNo + vbQuestion, "文件已经存在")
                    If retVal = vbYes Then
                        Exit Sub
                    End If
                End If
            End If
            
            m_strFile = strFileName
            If m_FtpConnection.UploadFile(.FileName, strFileName, lStartPoint) Then
                ListFiles tvTreeView.SelectedItem
            Else
                MsgBox "不能上载文件." & vbCrLf & vbCrLf & _
                        "Server response: " & m_FtpConnection.GetLastServerResponse, , "Can't upload file"
            End If
        End If
    End With

End Sub

Private Sub mnuView_Click()

    With m_FtpConnection
        mnuOptions.Enabled = Not .Busy
    End With
    
End Sub

Private Sub Option1_Click(Index As Integer)

    'm_FtpConnection.TransferMode = IIf(Index = 0, FTP_TYPE_ASCII, FTP_TYPE_IMAGE)

End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
'工具栏事件
    Dim strTemp As String
    
    On Error Resume Next
    Select Case Button.Key
        '连接
        Case "Connect"
            Call EstablishConnection
        '上一级目录
        Case "UpLevel"
            Set tvTreeView.SelectedItem = tvTreeView.SelectedItem.Parent
            strTemp = tvTreeView.SelectedItem.FullPath
            strTemp = Mid$(strTemp, InStr(1, strTemp, "/"))
            If m_FtpConnection.SetCurrentDirectory(strTemp) Then
                ListFiles tvTreeView.SelectedItem
            End If
        '停止
        Case "Stop"
            If Not m_FtpConnection.CloseConnection Then
                If m_FtpConnection.FtpGetLastError = ERROR_FTP_USER_TRANSFER_IN_PROGRESS Then
                    Dim intRetVal As Integer
                    intRetVal = MsgBox("Data transfer in progress. Do you want to cancel the data transfer?", vbYesNo + vbQuestion)