inet.frm

vb网络通信协议,参考例程

End Sub

'-------------------------------------------------------------------
'该函数的功能是向listserverdir控件中加入子目录
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub AddDirToListServerDir(tempStr As String)
Dim itmX As ListItem
    Set itmX = ListServerDir.ListItems.Add(, , tempStr)
    itmX.Icon = 1
    itmX.SmallIcon = 1

End Sub


Private Sub DownFile(SourceFile As String, DestinatonFile As String)
    OperationStyle = 7
    Inet1.Execute , "GET " & Trim(SourceFile) & " " & Trim(DestinatonFile)
End Sub
Private Sub UpFile(SourceFile As String, DestinatonFile As String)
    OperationStyle = 8
    Inet1.Execute , "SEND " & Trim(SourceFile) & " " & Trim(DestinatonFile)
End Sub

'-------------------------------------------------------------------
'该函数的功能是列出服务器指定目录的下的文件和子目录
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub ListServer(DirStr As String)
If Not Inet1.StillExecuting Then
    'ListServerDir.Enabled = False
    OperationStyle = 1
    Inet1.Execute , "LS " & DirStr
End If
End Sub

'-------------------------------------------------------------------
'该函数的功能是初始化inet1控件
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub InitInet()

With Inet1
    If Left(Trim(txtURl.Text), 6) <> "ftp://" Then
        .URL = "ftp://" & Trim(txtURl.Text)
    End If
    If txtPort.Text <> "" Then
        .RemotePort = CInt(Trim(txtPort.Text))
    Else
        .RemotePort = 21
    End If
    If Trim(txtUID.Text) <> "" Then
   
        .UserName = Trim(txtUID.Text)
        .Password = Trim(txtPWD.Text)
    End If
End With
CurrentServerDir = ""
If Inet1.StillExecuting Then
    MsgBox "无法断开保持连接"
    Exit Sub
End If


'列出服务器根目录
ListServer ("*")

End Sub


'-------------------------------------------------------------------
'初始化listclientdir控件的函数
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub InitListClientDir()
Dim itmX As ListItem


If Right(Dir1.Path, 1) <> "\" Then
    CurrentDir = Dir1.Path & "\"
    cmdUpDir.Enabled = True
    Dname = ".."
    Set itmX = ListClientDir.ListItems.Add(, , Dname)
    itmX.Icon = 3
    itmX.SmallIcon = 3
Else
    CurrentDir = Dir1.Path
    cmdUpDir.Enabled = False
End If

Combo1.Text = CurrentDir

AddFileToListClientDir

AddDirToListClientDir
End Sub

'-------------------------------------------------------------------
'向ListClientDir控件加入当前目录下的文件
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub AddFileToListClientDir()
Dim itmX As ListItem
Dim Fname As String
For Counter = 0 To File1.ListCount - 1
    Fname = File1.List(Counter)
    Set itmX = ListClientDir.ListItems.Add(, , Fname)
    itmX.Icon = 2
    itmX.SmallIcon = 2
    itmX.SubItems(1) = FileDateTime(CurrentDir & Fname)
Next Counter
End Sub

'-------------------------------------------------------------------
'向ListClientDir控件加入当前目录下的子目录
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub AddDirToListClientDir()
Dim itmX As ListItem
Dim Dname, TempDname As String
Dim Counter, Counter2 As Integer
For Counter = 0 To Dir1.ListCount - 1
    Dname = Dir1.List(Counter)
    For Counter2 = Len(Dname) To 1 Step -1
        If Mid$(Dname, Counter2, 1) = "\" Then
            TempDname = Right(Dname, Len(Dname) - Counter2)
            Exit For
        End If
    Next Counter2
    Set itmX = ListClientDir.ListItems.Add(, , TempDname)
    itmX.Icon = 1
    itmX.SmallIcon = 1
    itmX.SubItems(1) = FileDateTime(Dname)
Next Counter

End Sub

Private Sub ListClientDir_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
ListClientDir.SortKey = ColumnHeader.Index - 1
End Sub

Private Sub ListClientDir_DblClick()
Dim Item As ListItem

If ListClientDir.HitTest(xpos, ypos) Is Nothing Then
    Exit Sub
Else
    Set Item = ListClientDir.HitTest(xpos, ypos)
End If

If (GetAttr(CurrentDir & Item) And vbDirectory) <= 0 Then Exit Sub
ListClientDir.ListItems.Clear 'Clear Out Old Items

ChDir Item
Dir1.Path = CurDir
InitListClientDir
End Sub


Private Sub ListClientDir_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
xpos = x
ypos = y
End Sub

Private Sub ListServerDir_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
ListServerDir.SortKey = ColumnHeader.Index - 1
End Sub

Private Sub ListServerDir_DblClick()
Dim Item As ListItem
If Inet1.StillExecuting Then
    MsgBox "程序还在执行"
    'Inet1.Cancel
Else
    If ListServerDir.HitTest(xpos1, ypos1) Is Nothing Then
        Exit Sub
    Else
        Set Item = ListServerDir.HitTest(xpos1, ypos1)
    End If
    If Right(CStr(Item), 1) = "/" Then
        CurrentServerDir = CurrentServerDir & Item
        ListServer (CurrentServerDir)
    Else
        Exit Sub
    End If
End If
End Sub

Private Sub ListServerDir_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)

xpos1 = x
ypos1 = y

End Sub

'-------------------------------------------------------------------
'该函数的功能是获得每个文件和目录的大小
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub GetFileSize()
Dim i As Integer
OperationStyle = 2
If ListIndex < ListServerDir.ListItems.Count + 1 Then
    Set itemA = ListServerDir.ListItems.Item(ListIndex)
    Inet1.Execute , "size " & CurrentServerDir & ListServerDir.ListItems(ListIndex)
End If
End Sub

'-------------------------------------------------------------------
'该函数的功能是删除服务器端的目录
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub DeleteServerDir(DirPath As String)
OperationStyle = 3
Inet1.Execute , "RMDIR " & DirPath
End Sub

'-------------------------------------------------------------------
'该函数的功能是删除服务器端的文件
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------
Private Sub DeleteServerFile(FilePath As String)
OperationStyle = 4
Inet1.Execute , "delete " & FilePath
End Sub

'-------------------------------------------------------------------
'该函数的功能是删除服务器端的文件
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------
Private Sub RnameServerFile(FilePath As String, OldFileName As String, NewFileName As String)
OperationStyle = 5
Inet1.Execute , "rename " & FilePath & OldFileName & " " & _
                FilePath & NewFileName
End Sub
'-------------------------------------------------------------------
'该函数的功能是在服务器上创建新的目录
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------


Private Sub CreateServerDir(NewDir As String)
OperationStyle = 6
Inet1.Execute , "mkdir " & CurrentServerDir & NewDir
End Sub

Private Sub ListServerDir_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Item As ListItem

If Button = 2 Then
    If ListServerDir.HitTest(xpos1, ypos1) Is Nothing Then
        Exit Sub
    Else
        Set Item = ListServerDir.HitTest(xpos1, ypos1)
        Set itemA = Item
        If Right(Item, 1) <> "/" Then
            sdeletedir.Enabled = False
            screatedir.Enabled = True
            sdeletefile.Enabled = True
            srename.Enabled = True
        Else
            sdeletedir.Enabled = True
            screatedir.Enabled = True
            sdeletefile.Enabled = False
            srename.Enabled = False
        End If
        PopupMenu mnuServer
    End If
End If
End Sub

Private Sub screatedir_Click()
If Inet1.StillExecuting Then
    MsgBox "程序仍在连接!"
Else
    NewDir = InputBox("请输入要创建的目录:", "创建目录", "wxp")
    If Trim(NewDir) <> "" Then
        CreateServerDir (NewDir)
    End If
End If
End Sub

Private Sub sdeletedir_Click()
If Inet1.StillExecuting Then
    MsgBox "程序仍在连接!"
Else
    DeleteServerDir (CurrentServerDir & itemA)
End If
End Sub


Private Sub sdeletefile_Click()
If Inet1.StillExecuting Then
    MsgBox "程序仍在连接!"
Else
    DeleteServerFile (CurrentServerDir & itemA)
End If
End Sub

Private Sub srename_Click()
If Inet1.StillExecuting Then
    MsgBox "程序仍在连接!"
Else
    OldFileName = itemA
    NewFileName = InputBox("原来的文件名为：" & itemA, "请输入新的文件名")
    If NewFileName = itemA Then
        MsgBox "新旧文件名相同！"
    ElseIf Trim(NewFileName) <> "" Then
        RnameServerFile CurrentServerDir, OldFileName, NewFileName
    End If
End If
End Sub