'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 Winsock Control 6.0 (SP5) (MSWINSCK.OCX)'
' wird benötigt.
'--------- Anfang Formular "Form1" alias Form1.frm ---------
'Control Frame: Frame1
'Control CommandButton: Command1
'Control Timer: Timer1
'Control PictureBox: Picture1
'Control FileListBox: File1
'Control DirListBox: Dir1
'Control DriveListBox: Drive1
'Control TextBox: Text1
'Control Winsock: Winsock1
'Control Label: Label2
'Control Label: Label1
'Control Label: Label3
'Control Label: Label4
'Control Label: Label5
'Control Label: Label6
Option Explicit
Const ResponseTimeOut = 20 '20 Sekunden
Const PaketSize = 2048
Dim Start&
Dim OkFlag As Boolean
Dim TimeOut As Boolean
Dim Connected As Boolean
Private Sub Form_Load()
Timer1.Enabled = False
Timer1.Interval = 400
Winsock1.LocalPort = CInt(Text1.Text)
Winsock1.Listen
Label2.Caption = "Nicht verbunden"
Label3.Caption = App.Path & "\Testdatei.bmp"
If Dir$(Label3.Caption) <> "" Then
Label4.Caption = Int((FileLen(Label3.Caption) / 1024) * 10) _
/ 10 & " kB"
End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unload Form2
End Sub
Private Sub Command1_Click()
Call SendFile(Label3.Caption)
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Dir1_Change()
File1.Path = Dir1.Path
End Sub
Private Sub File1_Click()
Dim AA$, BB$
AA = File1.Path
If Right$(AA, 1) <> "\" And Right$(AA, 1) <> "/" Then
AA = AA & "\"
End If
Label3.Caption = AA & File1.FileName
Label4.Caption = Int((FileLen(Label3.Caption) / 1024) * 10) _
/ 10 & " kB"
End Sub
Private Sub Timer1_Timer()
If Timer - Start > ResponseTimeOut Then
TimeOut = True
OkFlag = False
End If
End Sub
Private Sub Winsock1_ConnectionRequest(ByVal requestID As Long)
If Winsock1.State <> sckClosed Then Winsock1.Close
Winsock1.Accept requestID
Winsock1.SendData 77
Label2.Caption = "Verbunden, bereit"
Connected = True
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim Data() As Byte
Winsock1.GetData Data, vbString
If Data(0) = 77 Then
OkFlag = False
End If
End Sub
Private Sub SendFile(FileName$)
Dim Data() As Byte
Dim l&, AA$, BB$, x&, FN%, TM As Single
On Error Resume Next
If Not Connected Then
MsgBox ("Es besteht keine Verbindung zum Client!")
Exit Sub
End If
Call Disable
l = FileLen(FileName)
AA = Hex(l)
Do While Len(AA) < 8
AA = "0" & AA
Loop
BB = LastPath(FileName)
BB = BB & Space$(257 - Len(BB))
AA = "New Data|" & AA & BB
ReDim Data(0 To Len(AA) - 1)
For x = 1 To Len(AA)
Data(x - 1) = Asc(Mid$(AA, x, 1))
Next x
Winsock1.SendData Data
If WaitForResponse Then
FN = FreeFile
Open FileName For Binary As #FN
ReDim Data(1 To PaketSize) As Byte
Label2.Caption = "Sende Daten"
Label2.Refresh
l = LOF(FN)
TM = Timer
For x = 1 To l \ PaketSize
Get #FN, , Data
Winsock1.SendData Data
Call ProgressBar(x * PaketSize, 0, l)
Label5.Caption = Int(x * PaketSize / 1024 / (Timer - TM) * _
10) / 10 & " kB/Sec"
Label5.Refresh
If Not WaitForResponse Then
MsgBox ("Übertragunsfehler")
Call ProgressBar(0, 0, l)
Label2.Caption = "Verbunden, bereit"
Call Enable
Exit Sub
End If
Next x
If l Mod PaketSize <> 0 Then
ReDim Data(1 To l Mod PaketSize) As Byte
Get #FN, , Data
Winsock1.SendData Data
Call ProgressBar(l, 0, l)
Label5.Caption = Int(x * PaketSize / 1024 / (Timer - TM) * _
10) / 10 & " kB/Sec"
Label5.Refresh
If Not WaitForResponse Then
MsgBox ("Übertragunsfehler")
Call ProgressBar(0, 0, l)
Label2.Caption = "Verbunden, bereit"
Call Enable
Exit Sub
End If
End If
Close FN
Label2.Caption = "Verbunden, bereit"
Call ProgressBar(0, 0, l)
Else
Label2.Caption = "Timeout"
MsgBox ("Konnte Verbindung nicht herstellen!")
End If
Call Enable
End Sub
Private Function WaitForResponse() As Boolean
OkFlag = True
TimeOut = False
Start = Timer
Timer1.Enabled = True
Do While OkFlag
DoEvents
Loop
If Not TimeOut Then WaitForResponse = True
Timer1.Enabled = False
End Function
Private Sub ProgressBar(ByVal Prg&, ByVal Min&, ByVal Max&)
Dim Fx&
Static LastX
If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub
Prg = Int(100 / (Max - Min) * (Prg - Min))
With Picture1
If Prg > 0 Then
If Prg <> LastX Then
Picture1.Cls
Fx = (Picture1.ScaleWidth - 2) / 100 * Prg
Picture1.Line (0, 0)-(Fx + 1, Picture1.ScaleHeight _
- 1), &H8000000D, BF
.CurrentX = Fx + 3
.CurrentY = 0
Picture1.Print Trim$(CStr(Prg) & " %")
LastX = Prg
End If
Else
Picture1.Cls
End If
End With
End Sub
Private Function LastPath(ByVal Path$) As String
Dim AA$, BB$, x&
For x = Len(Path) To 1 Step -1
AA = Mid$(Path, x, 1)
If AA = "/" Or AA = "\" Then
Exit For
Else
BB = AA & BB
End If
Next x
LastPath = BB
End Function
Private Sub Disable()
Text1.Enabled = False
Command1.Enabled = False
File1.Enabled = False
Dir1.Enabled = False
Drive1.Enabled = False
MousePointer = vbHourglass
End Sub
Private Sub Enable()
Text1.Enabled = True
Command1.Enabled = True
File1.Enabled = True
Dir1.Enabled = True
Drive1.Enabled = True
MousePointer = vbDefault
End Sub
'---------- Ende Formular "Form1" alias Form1.frm ----------
'--------- Anfang Formular "Form2" alias Form2.frm ---------
'Control Frame: Frame1
'Control CommandButton: Command1
'Control PictureBox: Picture1
'Control Timer: Timer1
'Control DriveListBox: Drive1
'Control DirListBox: Dir1
'Control FileListBox: File1
'Control TextBox: Text1
'Control TextBox: Text2
'Control Winsock: Winsock1
'Control Label: Label8
'Control Label: Label1
'Control Label: Label2
'Control Label: Label4
'Control Label: Label3
'Control Label: Label7
'Control Label: Label9
'Control Label: Label5
Option Explicit
Const ResponseTimeOut = 20 '20 Sekunden
Dim Start&
Dim OkFlag As Boolean
Dim TimeOut As Boolean
Dim Connected As Boolean
Dim Awaiting As Boolean
Private Sub Form_Load()
Timer1.Enabled = False
Timer1.Interval = 400
Drive1.Drive = "c:"
Dir1.Path = "c:"
With Form1
.Show
.Top = Screen.Height / 2
.Left = (Screen.Width - .Width) / 2
End With
With Me
.Left = Form1.Left
.Top = Form1.Top - .Height
End With
End Sub
Private Sub Form_Unload(Cancel As Integer)
Unload Form1
End Sub
Private Sub Command1_Click()
On Error Resume Next
Winsock1.Connect Text2.Text, CInt(Text1.Text)
Awaiting = True
If WaitForResponse Then
Label1.Caption = "Verbunden, bereit"
Command1.Enabled = False
Else
MsgBox ("Konnte keine Verbindung zum Server hestellen")
Winsock1.Close
End If
Awaiting = False
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Dir1_Change()
Dim AA$
AA = Dir1.Path
If Right$(AA, 1) <> "\" And Right$(AA, 1) <> "/" Then
AA = AA & "\"
End If
Label8.Caption = AA
File1.Path = Dir1.Path
End Sub
Private Sub Timer1_Timer()
If Timer - Start > ResponseTimeOut Then
TimeOut = True
OkFlag = False
End If
End Sub
Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
Dim Data() As Byte
Dim AA$, BB$, x&, d As Single
Static Rec As Boolean
Static TotalLen&
Static IsLen&
Static FN%
Static TM As Single
Winsock1.GetData Data, vbString
If Awaiting Then
If Data(0) = 77 Then OkFlag = False
Else
If UBound(Data) = 273 And Not Rec Then
For x = 0 To UBound(Data)
AA = AA & Chr$(Data(x))
Next x
If Left$(AA, 9) = "New Data|" Then
TotalLen = CLng("&H" & Mid$(AA, 10, 8))
If TotalLen <> 0 Then
BB = Trim$(Mid$(AA, 18))
Label1.Caption = "Empfange die Datei " & Chr$(34) & _
BB & Chr$(34)
Label4.Caption = Int((TotalLen / 1024) * 10) / 10 & _
" kB"
Call Dir1_Change
Label8.Caption = Label8.Caption & BB
TM = Timer
Call Disable
Else
TotalLen = 0
End If
End If
If TotalLen <> 0 Then
Winsock1.SendData 77
Rec = True
FN = FreeFile
IsLen = 0
If Dir$(Label8.Caption) <> "" Then
Kill Label8.Caption
End If
Open Label8.Caption For Binary As #FN
End If
ElseIf Rec Then
Put #FN, , Data
IsLen = IsLen + UBound(Data) + 1
d = (Timer - TM)
If d <> 0 Then Label3.Caption = Int(IsLen / 1024 / _
d * 10) / 10 & " kB/Sec"
Call ProgressBar(IsLen, 0, TotalLen)
If IsLen = TotalLen Then
Close FN
MsgBox ("Übertragung erfolgreich beendet!")
Call ProgressBar(0, 0, TotalLen)
Rec = False
Call Enable
TotalLen = 0
File1.Refresh
BB = LastPath(Label8.Caption)
If File1.ListCount > 0 Then
For x = 0 To File1.ListCount - 1
If File1.List(x) = BB Then
File1.ListIndex = x
Exit For
End If
Next x
Label1.Caption = "Verbunden, bereit"
End If
End If
Winsock1.SendData 77
End If
End If
End Sub
Private Sub ProgressBar(ByVal Prg&, ByVal Min&, ByVal Max&)
Dim Fx&
Static LastX
If Prg < Min Or Prg > Max Or Max <= Min Then Exit Sub
Prg = Int(100 / (Max - Min) * (Prg - Min))
With Picture1
If Prg > 0 Then
If Prg <> LastX Then
Picture1.Cls
Fx = (Picture1.ScaleWidth - 2) / 100 * Prg
Picture1.Line (0, 0)-(Fx + 1, Picture1.ScaleHeight _
- 1), &H8000000D, BF
.CurrentX = Fx + 3
.CurrentY = 0
Picture1.Print Trim$(CStr(Prg) & " %")
LastX = Prg
End If
Else
Picture1.Cls
End If
End With
End Sub
Private Function WaitForResponse() As Boolean
OkFlag = True
TimeOut = False
Start = Timer
Timer1.Enabled = True
Do While OkFlag
DoEvents
Loop
If Not TimeOut Then WaitForResponse = True
Timer1.Enabled = False
End Function
Private Function LastPath(ByVal Path$) As String
Dim AA$, BB$, x&
For x = Len(Path) To 1 Step -1
AA = Mid$(Path, x, 1)
If AA = "/" Or AA = "\" Then
Exit For
Else
BB = AA & BB
End If
Next x
LastPath = BB
End Function
Private Sub Disable()
Text1.Enabled = False
Text2.Enabled = False
Dir1.Enabled = False
Drive1.Enabled = False
MousePointer = vbHourglass
End Sub
Private Sub Enable()
Text1.Enabled = True
Text2.Enabled = True
Dir1.Enabled = True
Drive1.Enabled = True
MousePointer = vbDefault
End Sub
'---------- Ende Formular "Form2" alias Form2.frm ----------
'-------------- Ende Projektdatei Project1.vbp --------------