'Script Zum Fehlerfreiem Versenden Von Bildern Jeder Größe Über Winsock
'Dieses Script kann frei genutzt werden.
'Autor: Lars Schöning
'Benötigt:
'         Picture1 (Scalemode: Pixel, AutoSize: True)
'         Picture2 (~, Autoredraw: True)
'         Command2 (Caption: "Verbinden und Senden")
'         Winsock1,2 (TCP)
'         ProgressBar1,2
 
'RückWerte
Public BackMessage As Boolean
Public ErrorMessage As Boolean
 
'Konstanten
Const PieceSize = 40         'Kantenlänge Stückchengröße (Achtung!, über 40 
' gibts verstärkt Fehlermeldungen) - Dennoch - je größer: je schneller
Const Timeout = 500          'Timeout in Millisekunden - kann ruhig klein sein, 
' verursacht nur wiederholtes Senden
 
'Zeit In Millisekunden
Private Declare Function timeGetTime Lib "winmm.dll" () As Long
 
'Zum Kopieren von Bildteilen
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal X As _
  Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal _
  hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) _
  As Long
 
Private Sub Command2_Click()
 
    'Verbinden
    Winsock1.Close
    Winsock1.LocalPort = 123
    Winsock1.Listen
 
    Winsock2.Connect Winsock1.LocalIP, 123
 
    'Warten Bis Verbindung Aufgebaut
    Do
    DoEvents
    Loop Until Winsock2.State = 7 Or Winsock2.State = 9
 
    'Wenn Verbindung aufgebaut
    If Winsock2.State = 7 Then
 
        'Alle Bildstücke Häppchenweise senden.
        For X = 1 To Picture1.ScaleWidth Step PieceSize
            Prozentzahl = Round(100 * X / Picture1.ScaleWidth)
 
            For Y = 1 To Picture1.ScaleHeight Step PieceSize
 
StartSend:
 
            'Rücknachricht Zurücksetzen
            BackMessage = False
            TimeBefore = MilliTime
 
            'Wichtigster Teil - Bild Senden
            NoError = SendImage(Me, X, Y, PieceSize, Winsock2, Picture1, _
              Prozentzahl)
 
            'Wenn Socket Fehler, dann Alarm Schlagen
            If NoError = False Then MsgBox "Fehler!" & vbCrLf & "Verbindung" & _
              "wurde Unterbrochen", vbCritical
 
            'Wichtig, warten auf Reaktion, Fehler Oder Timeout
            Do
                If TimeBefore - MilliTime > Timeout Then
                    ErrorMessage = True
                    BackMessage = True
                End If
 
                If Winsock2.State <> 7 Then GoTo VerbindungsFehler
 
            DoEvents
            Loop Until BackMessage = True
 
            'Eben nochmal
            If ErrorMessage = True Then GoTo StartSend
 
            'SendeProgress
            ProgressBar1 = Prozentzahl
            Next
        Next
 
    Else
        'Sonst Fehler
        MsgBox "Fehler!" & vbCrLf & "Verbindung konnte nicht Hergestellt" & _
          "werden", vbCritical
    End If
 
Exit Sub
VerbindungsFehler:
MsgBox "Fehler!" & vbCrLf & "Verbindung wurde Unterbrochen", vbCritical
End Sub