已知一个服务器的网址\用户名和密码,如何用VB自动连接?

对不起,是ftp
(本来写明了的,英文字符被干掉了!)

有现成的组件啊, 好像是 inet
很简单的,你试试

使用inet，下面是代码，要想要源代码的话发邮件过来~~  Dim InetData As Variant
Dim CurrentDir As String
Dim CurrentServerDir As String
Dim xpos As Long, ypos As Long
Dim xpos1 As Long, ypos1 As Long
Dim OperationStyle As Integer
'创建的新的目录名
Dim NewDir As String
'新文件名
Dim NewFileName As String
'原来文件名
Dim OldFileName As String
Dim itemA As ListItem
'表示已经得到文件的大小
Dim SizeGet As Boolean
Dim ListIndex As Integer
'1表示列出服务器目录
'2表示获得文件大小
Private Sub cmdCancel_Click()
If Not Inet1.StillExecuting Then
    Inet1.Cancel
    'Inet1.Execute , "close"
Else
    MsgBox "系统正在忙！"
End If
End SubPrivate Sub cmdConnect_Click()
InitInet
End Sub
Private Sub cmdDownLoad_Click()
On Error Resume Next
    DownFile CurrentServerDir & ListServerDir.SelectedItem, CurrentDir & ListServerDir.SelectedItem
End Sub
Private Sub cmdUpDir_Click()
ChDir ".."
Dir1.Path = CurDirIf Right(Dir1.Path, 1) <> "\" Then
    CurrentDir = Dir1.Path & "\"
    cmdUpDir.Enabled = True
Else
    CurrentDir = Dir1.Path
    cmdUpDir.Enabled = False
End If
ListClientDir.ListItems.Clear 'Clear Out Old ItemsCombo1.Text = CurrentDirAddFileToListClientDirAddDirToListClientDirEnd SubPrivate Sub cmdUpLoad_Click()
On Error Resume Next
    UpFile CurrentDir & ListClientDir.SelectedItem, CurrentServerDir & ListClientDir.SelectedItem
End SubPrivate Sub cmdUpSDir_Click()
If CurrentServerDir <> "" Then
    If Inet1.StillExecuting Then
        MsgBox "还没有执行完毕!"
    Else
        ListServer UpServerDir
    End If
Else
    MsgBox "已经到了最上一层目录!"
End If
End SubPrivate Function UpServerDir() As String
Dim tempPos1 As Integer
On Error Resume Next
If CurrentServerDir <> "" Then
    tempPos1 = InStrRev(CurrentServerDir, "/", Len(CurrentServerDir) - 1, vbTextCompare)
    CurrentServerDir = Mid(CurrentServerDir, 1, tempPos1)
    UpServerDir = CurrentServerDir
End If
End Function
Private Sub Dir1_Change()
OperationStyle = 6
File1.Path = Dir1.Path
End SubPrivate Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End SubPrivate Sub Form_Load()
With ListClientDir
    .View = lvwReport
    .ColumnHeaders.Add , "name", "名称", 1000
    .ColumnHeaders.Add , "date", "日期时间", 1800
End WithWith ListServerDir
    .View = lvwReport
    .ColumnHeaders.Add , "name", "名称", 800
    .ColumnHeaders.Add , "size", "大小", 800
    .ColumnHeaders.Add , "date", "日期", 800
    .ColumnHeaders.Add , "time", "时间", 800
    .ColumnHeaders.Add , "property", "属性", 800
End With
'把驱动器设置成当前驱动器
ChDrive Drive1.Drive
'把目录设置成当前目录
Dir1.Path = CurDirInitListClientDir
End SubPrivate Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
DoEvents
Set form_inet = Nothing
End SubPrivate Sub Inet1_StateChanged(ByVal State As Integer)
Dim tempArray As Variant
Dim i As Integer
Dim FileSize As Variant
Dim itmX As ListItemOn Error Resume Next
Select Case State
    Case 0 'icNone
        Text1.Text = Text1.Text & vbCrLf & "无状态可报告"
    Case 1 'icHostResolvingHost
        Text1.Text = Text1.Text & vbCrLf & "正在查询所指定的主机的 IP 地址"
    Case 2 'icHostResolved
        Text1.Text = Text1.Text & vbCrLf & "已成功地找到所指定的主机的 IP 地址"
    Case 3 'icConnecting
        Text1.Text = Text1.Text & vbCrLf & "正在与主机连接"
    Case 4 'icConnected
        Text1.Text = Text1.Text & vbCrLf & "已与主机连接成功"
    Case 5 'icRequesting
        Text1.Text = Text1.Text & vbCrLf & "正在向主机发送请求"
    Case 6 'icRequestSent
        Text1.Text = Text1.Text & vbCrLf & "发送请求已成功"
    Case 7 'icReceivingResponse
        Text1.Text = Text1.Text & vbCrLf & "正在接收主机的响应"
    Case 8 'icResponseReceived
        Text1.Text = Text1.Text & vbCrLf & "已成功地接收到主机的响应"
    Case 9 'icDisconnecting
        Text1.Text = Text1.Text & vbCrLf & "正在解除与主机的连接"
    Case 10 'icDisconnected
        Text1.Text = Text1.Text & vbCrLf & "已成功地与主机解除了连接"
    Case 11 'icError
        Text1.Text = Text1.Text & vbCrLf & "与主机通讯时出现了错误"
        Text1.Text = Text1.Text & vbCrLf & "错误" & Inet1.ResponseCode & ":" & Inet1.ResponseInfo
    Case 12 'icResponseCompleted
        Text1.Text = Text1.Text & vbCrLf & "该请求已经完成，并且所有数据均已接收到"
        Select Case OperationStyle
            Case 1 '列出目录和文件
                ListServerDir.ListItems.Clear
                InetData = Inet1.GetChunk(1024, 0) '0表示把数据作为字符串来检索，1表示把数据作为字节数组来检索
                If Trim(InetData) <> 0 Then
                    tempArray = Split(InetData, vbCrLf, , vbTextCompare)
                    Combo2.Text = "Root/" & CurrentServerDir
                    i = 0
                    Do While i < UBound(tempArray)
                        If tempArray(i) <> "" Then
                            DealListServerDir (tempArray(i))
                        End If
                        i = i + 1
                    Loop
                    ListIndex = 1
                End If
                'GetFileSize
            Case 2 '获得每个文件的大小
                FileSize = Inet1.GetChunk(1024, 0)
                itemA.SubItems(1) = CStr(FileSize)
                ListIndex = ListIndex + 1
                GetFileSize
            Case 3 '删除目录
                Text1.Text = Text1.Text & vbCrLf & itemA & "目录被删除!"
                ListServerDir.ListItems.Remove (ListServerDir.SelectedItem.Index)
            Case 4 '删除文件
                Text1.Text = Text1.Text & vbCrLf & itemA & "文件被删除!"
                ListServerDir.ListItems.Remove (ListServerDir.SelectedItem.Index)
            Case 5 '更改文件名
                Text1.Text = Text1.Text & vbCrLf & itemA & "文件被改名为" & NewFileName
                ListServerDir.SelectedItem.Text = NewFileName
            Case 6 '创建目录
                Text1.Text = Text1.Text & vbCrLf & NewDir & "目录被创建!"
                Set itmX = ListServerDir.ListItems.Add(, , NewDir & "/")
                itmX.SmallIcon = 1
                itmX.Icon = 1
            Case 7 '下载文件
                Text1.Text = Text1.Text & vbCrLf & ListServerDir.SelectedItem & "文件下载成功!"
                Set itmX = ListClientDir.ListItems.Add(, , ListServerDir.SelectedItem)
                itmX.Icon = 2
                itmX.SmallIcon = 2
            Case 8 '上载文件
                Text1.Text = Text1.Text & vbCrLf & ListClientDir.SelectedItem & "文件上载成功!"
                Set itmX = ListServerDir.ListItems.Add(, , ListClientDir.SelectedItem)
                itmX.Icon = 2
                itmX.SmallIcon = 2

            Case Else
        End Select
End Select
    Text1.SelLength = Len(Text1.Text)
End Sub'-------------------------------------------------------------------
'该函数的功能是处理从服务器端得到的数据
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------

Private Sub DealListServerDir(tempStr As String)
If Right(Trim(tempStr), 1) <> "/" Then
    '表示接受到的是文件
    AddFileToListServerDir (tempStr)
Else
    '表示接收到的是目录
    AddDirToListServerDir (tempStr)
End IfEnd Sub'-------------------------------------------------------------------
'该函数的功能是向listserverdir控件中加入指定目录下的文件
'Written by wxp
'date 2000-10
'-------------------------------------------------------------------Private Sub AddFileToListServerDir(tempStr As String)
Dim itmX As ListItem
    Set itmX = ListServerDir.ListItems.Add(, , tempStr)
    itmX.Icon = 2
    itmX.SmallIcon = 2
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 = 1End 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 IfCombo1.Text = CurrentDirAddFileToListClientDirAddDirToListClientDir
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 CounterEnd SubPrivate Sub ListClientDir_ColumnClick(ByVal ColumnHeader As MSComctlLib.ColumnHeader)
ListClientDir.SortKey = ColumnHeader.Index - 1
End SubPrivate Sub ListClientDir_DblClick()
Dim Item As ListItemIf ListClientDir.HitTest(xpos, ypos) Is Nothing Then
    Exit Sub
Else
    Set Item = ListClientDir.HitTest(xpos, ypos)
End IfIf (GetAttr(CurrentDir & Item) And vbDirectory) <= 0 Then Exit Sub
ListClientDir.ListItems.Clear 'Clear Out Old ItemsChDir 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 SubPrivate 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 SubPrivate Sub ListServerDir_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)xpos1 = x
ypos1 = yEnd 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 SubPrivate Sub ListServerDir_MouseUp(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim Item As ListItemIf 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 SubPrivate Sub screatedir_Click()
If Inet1.StillExecuting Then
    MsgBox "程序仍在连接!"
Else
    NewDir = InputBox("请输入要创建的目录:", "创建目录", "wxp")
    If Trim(NewDir) <> "" Then
        CreateServerDir (NewDir)
    End If
End If
End SubPrivate 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 SubPrivate 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

调试易

已知一个服务器的网址\用户名和密码,如何用VB自动连接?

解决方案 »