Die Community zu .NET und Classic VB.
Menü

VB 5/6-Tipp 0288: Laufwerk eines Remote-Rechners via Winsock anzeigen lassen

 von 

Beschreibung 

Hiermit ist es möglich ein sich mittels Winsock den Laufwerksinhalt eines Remote-Rechners anzeigen zu lassen und gezielt Dateien von dort zu übertragen.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

Verwendete API-Aufrufe:

keine

Download:

Download des Beispielprojektes [5,54 KB]

'Dieser Quellcode stammt von http://www.activevb.de
'und kann frei verwendet werden. Für eventuelle Schäden
'wird nicht gehaftet.

'Um Fehler oder Fragen zu klären, nutzen Sie bitte unser Forum.
'Ansonsten viel Spaß und Erfolg mit diesem Source!

'------------- Anfang Projektdatei Project1.vbp -------------
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (mscomctl.ocx)' wird benötigt.
' Die Komponente ' (MSWINSCK.OCX)' wird benötigt.

'----- Anfang Formular "frmClient" alias frmClient.frm  -----
' Steuerelement: Rahmensteuerelement "Frame3"
' Steuerelement: Listen-Steuerelement "lstSuchergebnisse" auf Frame3
' Steuerelement: Schaltfläche "cmdSuchen" auf Frame3
' Steuerelement: Textfeld "txtSuchen" auf Frame3
' Steuerelement: Windows Socket "Client"
' Steuerelement: Rahmensteuerelement "Frame2"
' Steuerelement: Schaltfläche "cmdDownload" auf Frame2
' Steuerelement: Fortschrittsanzeige "prbProzent" auf Frame2
' Steuerelement: Textfeld "txtZiel" auf Frame2
' Steuerelement: Textfeld "txtQuelle" auf Frame2
' Steuerelement: Beschriftungsfeld "Label2" auf Frame2
' Steuerelement: Beschriftungsfeld "Label1" auf Frame2
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Schaltfläche "cmdVerbinden" auf Frame1
' Steuerelement: Beschriftungsfeld "lblAktivität" auf Frame1


'Autor: Dominik Weber
'E-Mail: freund2001@gmx.de

Option Explicit

Private Const DOWNLOADSTART = "d1"
Private Const DOWNLOAD = "d2"
Private Const DOWNLOADENDE = "d3"
Private Const SUCHEN = "s1"
Private Const ECHO = "e1"

Private DateiNr As Integer

Private Sub Client_Close()
On Error Resume Next
    lblAktivität.Caption = "Verbindung getrennt"
End Sub

Private Sub Client_Connect()
On Error Resume Next
    lblAktivität.Caption = "Verbunden mit Server"
    Frame2.Enabled = True
    Frame3.Enabled = True
End Sub

Private Sub Client_DataArrival(ByVal bytesTotal As Long)
On Error Resume Next
    Dim Daten As String
    Dim Befehl As String
    lblAktivität.Caption = "Bekomme Daten..."
    Client.GetData Daten
    Befehl = Left(Daten, 2)
    Daten = Mid(Daten, 3)
    Select Case Befehl
        Case DOWNLOADSTART
            prbProzent.Max = Int(Daten / 1024)
            SendData ECHO
        Case DOWNLOAD
            prbProzent.Value = prbProzent.Value + _
                               Int(Len(Daten) / 1024)
            Put #DateiNr, , Daten
            SendData ECHO
        Case DOWNLOADENDE
            prbProzent.Value = 0
            Close DateiNr
            lblAktivität.Caption = "Download beendet"
        Case SUCHEN
            lstSuchergebnisse.AddItem Daten
            lstSuchergebnisse.ListIndex = _
                    lstSuchergebnisse.ListCount - 1
            DoEvents
            SendData ECHO
    End Select
End Sub

Private Sub Client_Error(ByVal Number As Integer, Description _
                         As String, ByVal Scode As Long, ByVal _
                         Source As String, ByVal HelpFile As _
                         String, ByVal HelpContext As Long, _
                         CancelDisplay As Boolean)
                         
    On Error Resume Next
    lblAktivität.Caption = Description
    cmdVerbinden_Click
End Sub

Private Sub cmdDownload_Click()
On Error Resume Next
    DateiNr = FreeFile
    Open txtZiel For Binary Access Write As DateiNr
    SendData DOWNLOADSTART, txtQuelle.Text
End Sub

Private Sub cmdSuchen_Click()
On Error Resume Next
    SendData SUCHEN, txtSuchen
    lstSuchergebnisse.Clear
    lstSuchergebnisse.AddItem "Suchergebnisse für " & _
                               txtSuchen.Text & ":"
    lblAktivität.Caption = "warte auf Suchergebnisse..."
End Sub

Private Sub cmdVerbinden_Click()
On Error Resume Next
    If cmdVerbinden.Caption = "&Verbinden" Then
        cmdVerbinden.Caption = "&Trennen"
        lblAktivität.Caption = "verbinde..."
        Client.Connect
    Else
        cmdVerbinden.Caption = "&Verbinden"
        lblAktivität.Caption = "Verbindung getrennt"
        Client.Close
        Frame2.Enabled = False
        Frame3.Enabled = False
    End If
End Sub

Private Sub SendData(ByVal Befehl As String, Optional _
                     ByVal Text As String)
                     
On Error Resume Next
    lblAktivität.Caption = "sende Daten..."
    Client.SendData Befehl & Text
End Sub

Private Sub Form_Load()
  Me.Caption = "Client"
End Sub
'------ Ende Formular "frmClient" alias frmClient.frm  ------
'----- Anfang Formular "frmServer" alias frmServer.frm  -----
' Steuerelement: Windows Socket "Server"
' Steuerelement: Beschriftungsfeld "lblAktivität"


'Autor: Dominik Weber
'E-Mail: freund2001@gmx.de

Option Explicit

Private Const DOWNLOADSTART = "d1"
Private Const DOWNLOAD = "d2"
Private Const DOWNLOADENDE = "d3"
Private Const SUCHEN = "s1"
Private Const ECHO = "e1"

Private DateiNr As Integer
Private Warten As Boolean

Private Sub Form_Load()
On Error Resume Next
    frmClient.Show
    frmClient.Left = Me.Left + Me.Width
    frmClient.Top = Me.Top
    Show
    DoEvents
    Server.Listen
    Me.Caption = "Server"
End Sub

Private Sub Server_Close()
On Error Resume Next
    lblAktivität.Caption = "Verbindung getrennt"
    Server.Close
    Server.Listen
End Sub

Private Sub Server_ConnectionRequest(ByVal requestID As Long)
On Error Resume Next
    If Server.State <> sckClosed Then Server.Close
    Server.Accept requestID
    lblAktivität.Caption = "Verbunden mit Client"
End Sub

Private Sub Server_DataArrival(ByVal bytesTotal As Long)
    On Error Resume Next
    Dim Daten As String
    Dim Befehl As String
    Dim Temp As String
    Dim DownloadSchritt As Long
    lblAktivität.Caption = "Bekomme Daten..."
    Server.GetData Daten
    Befehl = Left(Daten, 2)
    Daten = Mid(Daten, 3)
    Select Case Befehl
        Case DOWNLOADSTART
            DateiNr = FreeFile
            Open Daten For Binary Access Read As DateiNr
                SendData DOWNLOADSTART, LOF(DateiNr)
                Do While Not EOF(DateiNr)
                    DownloadSchritt = 4092
                    If DownloadSchritt > LOF(DateiNr) - _
                                         Loc(DateiNr) Then
                      DownloadSchritt = LOF(DateiNr) - _
                                        Loc(DateiNr)
                    End If
                    If DownloadSchritt = 0 Then Exit Do
                    Temp = Space(DownloadSchritt)
                    Get #DateiNr, , Temp
                    SendData DOWNLOAD, Temp
                Loop
            Close DateiNr
            SendData DOWNLOADENDE
            lblAktivität.Caption = "Download beendet"
        Case SUCHEN
            lblAktivität.Caption = "starte Suche nach " _
                                   & Daten & "..."
            Suche Daten
            SendData SUCHEN, "-Suche beendet-"
        Case ECHO
            Warten = False
    End Select
End Sub

Private Sub Server_Error(ByVal Number As Integer, Description _
                         As String, ByVal Scode As Long, ByVal _
                         Source As String, ByVal HelpFile As _
                         String, ByVal HelpContext As Long, _
                         CancelDisplay As Boolean)
                         
    On Error Resume Next
    lblAktivität.Caption = Description
End Sub

Private Sub SendData(ByVal Befehl As String, Optional ByVal _
                     Text As String)
                     
    On Error Resume Next
    lblAktivität.Caption = "sende Daten..."
    Warten = True
    Server.SendData Befehl & Text
    Do While Warten
        DoEvents
    Loop
End Sub

Private Sub Suche(ByVal Datei As String)
    On Error Resume Next
    listadriv Datei
End Sub

Sub listadriv(ByVal Dateiname As String)
    On Error Resume Next
    Dim Fso
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim d, dc, S
    Set dc = Fso.Drives
    For Each d In dc
        If d.DriveType = 2 Or d.DriveType = 3 Then
            Call FindSubFolders(d.Path & "\", Dateiname)
        End If
    Next
End Sub

Sub FindSubFolders(folderspec, ByVal Dateiname As String)
    On Error Resume Next
    Dim AktuellerOrdner As String
    Dim Fso
    Set Fso = CreateObject("Scripting.FileSystemObject")
    Dim F, F1, sf
    Set F = Fso.GetFolder(folderspec)
    Set sf = F.subfolders
    For Each F1 In sf
        AktuellerOrdner = F1.Path
        If Right(AktuellerOrdner, 1) <> "\" Then
            AktuellerOrdner = AktuellerOrdner & "\*.*"
        Else
            AktuellerOrdner = AktuellerOrdner & "*.*"
        End If
        lblAktivität.Caption = "suche... " & AktuellerOrdner
        DoEvents
        Call FindFiles(F1.Path, Dateiname)
        Call FindSubFolders(F1.Path, Dateiname)
    Next
End Sub

Sub FindFiles(folderspec, ByVal Dateiname As String)
On Error Resume Next
    Dim Fso, Fc, F1, File1, F, S
    Set Fso = CreateObject("Scripting.FileSystemObject")
    File1 = UCase(Dateiname)
    Set F = Fso.GetFolder(folderspec)
    Set Fc = F.Files
    For Each F1 In Fc
        S = Fso.getfilename(F1.Path)
        S = UCase(S)
        DoEvents
        If Left(File1, 1) = "*" Then
            If Right(S, Len(File1) - 1) = Right(File1, _
                     Len(File1) - 1) Then
                SendData SUCHEN, F1.Path
            End If
        ElseIf S = File1 Then
            SendData SUCHEN, F1.Path
        End If
    Next
End Sub
'------ Ende Formular "frmServer" alias frmServer.frm  ------
'-------------- Ende Projektdatei Project1.vbp --------------

Tipp-Kompatibilität:

Windows/VB-VersionWin32sWin95Win98WinMEWinNT4Win2000WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version:

Windows-Version:

Ihre Meinung  

Falls Sie Fragen zu diesem Artikel haben oder Ihre Erfahrung mit anderen Nutzern austauschen möchten, dann teilen Sie uns diese bitte in einem der unten vorhandenen Themen oder über einen neuen Beitrag mit. Hierzu können sie einfach einen Beitrag in einem zum Thema passenden Forum anlegen, welcher automatisch mit dieser Seite verknüpft wird.

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 4 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.

Kommentar von FurzMaster am 12.10.2003 um 10:20

Wenn man eine Datei heruntergeladen hat, steht die CPU-Auslastung auf 100% bis man über den Taskmanager das Programm beendet hat.

Kommentar von W00DsT0CK am 29.05.2003 um 20:03

ich würde gern wissen, was man bei Tipp "0288: Laufwerk eines Remote-Rechners via Winsock anzeigen lassen" im "Suchen" eingeben muss um alle datein zu sehn (ich hab es mit *.* probiert aber es ha nicht funktionier), also nicht nur *.jpeg sondern
alle endungen.

Danke schon mal im Voraus.

Gruß W00DsT0CK

Kommentar von barni am 20.08.2002 um 14:27

Beim Übertragen von Binaer-Datein fehlen Teile der Datei.

Kommentar von deepblue am 31.01.2002 um 11:23

hm..also funz eh ganz gut, aber bei ner 125mb file hatte es probleme.
die downgeloadete datei war schon 186mb gross und der download hat noch immer nicht aufgehört.....sehr misteriös... :-)