exftpdir.frm

VB Modem编程及控件

      Top             =   650
      Width           =   1215
   End
   Begin VB.Label Label1 
      Caption         =   "FTP Server URL:"
      Height          =   300
      Left            =   240
      TabIndex        =   0
      Top             =   200
      Width           =   1575
   End
   Begin VB.Menu mnuPopup 
      Caption         =   "Popup"
      Visible         =   0   'False
      Begin VB.Menu mnuOpenRetrieve 
         Caption         =   "Open/Retrieve"
      End
      Begin VB.Menu mnuUploadStore 
         Caption         =   "Upload/Store"
      End
      Begin VB.Menu mnuSeparator 
         Caption         =   "-"
      End
      Begin VB.Menu mnuStatus 
         Caption         =   "Status"
      End
      Begin VB.Menu mnuDelete 
         Caption         =   "Delete"
      End
      Begin VB.Menu mnuHelp 
         Caption         =   "Help..."
      End
      Begin VB.Menu mnuMakeDir 
         Caption         =   "Make dir..."
      End
      Begin VB.Menu mnuRename 
         Caption         =   "Rename..."
      End
      Begin VB.Menu mnuSendFTPCommand 
         Caption         =   "Send FTP command..."
      End
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim SelectedItem As String
Private Sub ParseDirList(ByVal DirList As String)
  ' takes the dir list returned by ListDir and parses it for display in List
  Dim S As String
  If Len(DirList) > 0 Then
    List1.Clear
    ' FTP doesn't give us . or .., we'll add them ourselves
    List1.AddItem (".")
    List1.AddItem ("..")
    Dim I As Integer
    ' also, the dir list is a single <CR><LF> delimited string, we'll walk the
    ' string to break it up into separate lines
    For I = 1 To Len(DirList)
      If Mid(DirList, I, 1) = Chr(13) Then
        List1.AddItem (S)
        S = ""
      ElseIf Mid(DirList, I, 1) <> Chr(10) Then
        S = S & Mid(DirList, I, 1)
      End If
    Next I
  End If
End Sub

Private Sub Apax1_OnFTPError(ByVal ErrorCode As Long, ByVal ErrorText As String)
  ' we received an FTP error response.  We're expecting a 550 error when we
  ' double-click a file in List1
  If ErrorCode = 550 Then
    List2.AddItem ("Selection not a dir, must be a file")
  Else
    List2.AddItem ("FTP Error: " & ErrorText)
  End If
End Sub

Private Sub Apax1_OnFTPLog(ByVal LogCode As Apax1.TxFTPLogCode)
  Dim S As String
  Select Case LogCode
    Case lcClose
      S = "Disconnected"
    Case lcOpen
      S = "Connected to " & Apax1.FTPServerAddress
    Case lcComplete
      S = "Transfer complete. " & Apax1.FTPBytesTransferred & " bytes transferred."
    Case lcLogin
      S = Apax1.FTPUserName & " logged in"
      btnUpload.Enabled = True
    Case lcLogout
      S = Apax1.FTPUserName & " logged out"
      List1.Clear
      btnUpload.Enabled = False
    Case lcReceive
      S = "Downloading " + SelectedItem
    Case lcRename
      S = "Renaming " + SelectedItem
    Case lcRestart
      S = "Attempting re-transfer at " & Apax1.FTPRestartAt & " bytes"
    Case lcStore
      S = "Uploading " + SelectedItem
    Case lcTimeout
      S = "Transfer timed out"
    Case lcUserAbort
      S = "Transfer aborted by user"
    Case lcDelete
      S = "File deleted"
    Case Else
      S = "Unknown LogCode: " & LogCode
  End Select
  List2.AddItem ("FTPLog: " & S)
End Sub

Private Sub Apax1_OnFTPStatus(ByVal StatusCode As Apax1.TxFTPStatusCode, ByVal InfoText As String)
  If StatusCode = scProgress Then
    Dim S As String
    S = "Status: " & Apax1.FTPBytesTransferred & "/"
    ' FTPFileLength is only known if we're transmitting (Store), not when
    ' we are receiving (Retrieve). The only way to get the file length of
    ' a remote file is to get a full dir list or use Status, but the format
    ' of the response is not consistent across FTP servers
    If Apax1.FTPFileLength = 0 Then
      S = S & "???"
    Else
      S = S & Apax1.FTPFileLength
    End If
    List2.List(List2.ListCount - 1) = S
  End If
End Sub

Private Sub btnLogin_Click()
  ' set up the APAX FTP properties and log into the FTP server
  Apax1.FTPServerAddress = txtServerAddress.Text
  Apax1.FTPUserName = txtUsername.Text
  Apax1.FTPPassword = txtPassword.Text
  List2.AddItem ("Logging in")
  If Apax1.FTPLogIn = False Then
    MsgBox "Couldn't log in"
  Else
    Dim S As String
    S = Apax1.FTPListDir("", False)
    Call ParseDirList(S)
  End If
End Sub

Private Sub btnLogout_Click()
  ' terminate the FTP session by logging out
  On Error Resume Next
  Apax1.FTPLogOut
End Sub

Private Sub btnUpload_Click()
  ' select a file and upload it to the FTP server's current directory
  CommonDialog1.FileName = ""
  On Error GoTo ErrHandler
  CommonDialog1.ShowOpen
  If Apax1.FTPStore(CommonDialog1.FileTitle, CommonDialog1.FileName, smReplace) Then
    MsgBox ("Transfer complete")
  Else
    MsgBox ("Couldn't upload " & CommonDialog1.FileTitle)
  End If
ErrHandler:
  ' Open dialog cancelled
  Exit Sub
End Sub

Private Sub List1_DblClick()
  ' try to change the FTP server's directory, if we can't it's because the
  ' item we double-clicked isn't a dir, most likely it's a file so we'll
  ' download it
  If Apax1.FTPChangeDir(List1.Text) Then
    ' this was a directory, list it
    Caption = txtServerAddress.Text & Apax1.FTPCurrentDir
    Dim S As String
    S = Apax1.FTPListDir("", False)
    ParseDirList (S)
  Else
    ' this was not a directory, retrieve it
    CommonDialog1.CancelError = True
    On Error GoTo ErrHandler
    CommonDialog1.FileName = List1.Text
    CommonDialog1.ShowSave
    If Apax1.FTPRetrieve(List1.Text, CommonDialog1.FileName, rmReplace) Then
      MsgBox ("Transfer complete")
    Else
      MsgBox ("Couldn't save " & List1.Text)
    End If
  End If
ErrHandler:
  ' save dialog cancelled
  Exit Sub
End Sub

Private Sub List1_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
  If Button = vbRightButton Then
    Call PopupMenu(mnuPopup)
  End If
End Sub

Private Sub mnuDelete_Click()
  If Apax1.FTPDelete(List1.Text) Then
    Dim S As String
    S = Apax1.FTPListDir("", False)
    ParseDirList (S)
  Else
    MsgBox ("Couldn't delete " & List1.Text)
  End If
End Sub

Private Sub mnuHelp_Click()
  Dim S As String
  S = ""
  S = InputBox("Enter command to get help for (empty string returns a list of supported commands", "Get help", S)
  S = Apax1.FTPHelp(S)
  MsgBox (S)
End Sub

Private Sub mnuMakeDir_Click()
  Dim S As String
  S = InputBox("Enter directory name to create (blank dir cancels)")
  If Len(S) > 0 Then
    If Apax1.FTPMakeDir(S) Then
      MsgBox ("Directory created")
      S = Apax1.FTPListDir("", False)
      ParseDirList (S)
    Else
      MsgBox ("Couldn't make " & S)
    End If
  End If
End Sub

Private Sub mnuOpenRetrieve_Click()
  List1_DblClick
End Sub

Private Sub mnuRename_Click()
  Dim S As String
  S = InputBox("Enter new name", "Rename", List1.Text)
  If Len(S) > 0 Then
    If Apax1.FTPRename(List1.Text, S) Then
      S = Apax1.FTPListDir("", False)
      ParseDirList (S)
    Else
      MsgBox (List1.Text & " couldn't be renamed to " & S)
    End If
  End If
End Sub

Private Sub mnuSendFTPCommand_Click()
  Dim S As String
  S = InputBox("Enter command to send")
  If Len(S) > 0 Then
    MsgBox ("You sent: " & S & Chr(13) & Chr(10) & "Server replied: " & Chr(13) & Chr10) & Apax1.FTPSendFTPCommand(S)
  End If
End Sub

Private Sub mnuStatus_Click()
  Dim S As String
  S = Apax1.FTPStatus(List1.Text)
  If Len(S) > 0 Then
    MsgBox (S)
  Else
    MsgBox ("Couldn't get status for " & List1.Text)
  End If
  
End Sub

Private Sub mnuUploadStore_Click()
  btnUpload_Click
End Sub