Die Community zu .NET und Classic VB.

Startseite / Tipps / VB 5/6-Tipp 0741: Bilder per Winsock übertragen

VB 5/6-Tipp 0741: Bilder per Winsock übertragen

 von Henrik Ilgen

Schwierigkeitsgrad:

Verwendete API-Aufrufe: BitBlt

Download: Download des Beispielprojektes [61,17 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 BildTransfer.vbp -----------
' Die Komponente ' (MSWINSCK.OCX)' wird benötigt.
' --- Anfang Formular "frmTransfer" alias frmTransfer.frm  ---
' Steuerelement: Kontrollkästchen-Steuerelement "chkLiveBild"
' Steuerelement: Schaltfläche "cmdInfosSenden"
' Steuerelement: Schaltfläche "cmdPause"
' Steuerelement: Schaltfläche "cmdStart"
' Steuerelement: Textfeld "txtEreignisse"
' Steuerelement: Windows Socket "wskClient"
' Steuerelement: Windows Socket "wskServer"
' Steuerelement: Timersteuerelement "tmrÜbertragen"
' Steuerelement: Bildfeld-Steuerelement "picTemporär"
' Steuerelement: Bildfeld-Steuerelement "picZiel"
' Steuerelement: Bildfeld-Steuerelement "picQuelle"
' Steuerelement: Linien-Steuerelement "Line3"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Linien-Steuerelement "Line2"
' Steuerelement: Beschriftungsfeld "Label2"
' Steuerelement: Linien-Steuerelement "Line1"
' Steuerelement: Beschriftungsfeld "Label1"
Option Explicit

' picQuelle sollte ein Bild enthalten!
' BitBlt-API-Funktion.
'  Wird benötigt, um die einzelnen Teile zu kopieren.
'  PaintPicture würde den selben Zweck erfüllen, ist hier aber
'  unnötig kompliziert (zu viele Argumente) und ist langsamer.
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
                         
' Die Höhe und Breite der zu übertragenden Teile in Pixeln.
'  Mit diesem Wert muss man etwas herumexperimentieren,
'  es scheint vom Intervall des Timers abzuhängen, wie
'  groß die einzelnen Teile sein dürfen.
Private Const TransferGröße   As Long = 25

' Der zu benutzende Port für den Server.
'  Beim Schreiben des Codes traten oft Fehler auf, was
'  ein abruptes Beenden der Anwendung zur Folge hatte.
'  Danach musste jedesmal der Port gewechselt werden,
'  weil die Sockets nicht ordnungsgemäß geschlossen
'  wurden. Deswegen habe ich diese Konstante
'  eingeführt, um nur einen Wert ändern zu müssen.
' Der Client verwendet BenutzterPort + 1.
Private Const BenutzterPort   As Long = 1337
Private TeilBereitsÜbertragen() As Boolean

Private Sub cmdInfosSenden_Click()

    ' Transfer initialisieren
    Call TransferStarten
    
End Sub

Private Sub cmdPause_Click()

    tmrÜbertragen.Enabled = False
    cmdPause.Enabled = False
    cmdStart.Enabled = True
    
End Sub

Private Sub cmdStart_Click()

    If wskServer.State = sckConnected Then
    
        tmrÜbertragen.Enabled = True
        cmdPause.Enabled = True
        cmdStart.Enabled = False
        
    End If
    
End Sub

Private Sub Form_Load()

    ' BitBlt verwendet Pixel als Maßeinheit
    picQuelle.ScaleMode = vbPixels
    picZiel.ScaleMode = vbPixels
    picTemporär.ScaleMode = vbPixels
    
    ' Die temporäre PictureBox auf Größe bringen
    picTemporär.Height = TransferGröße
    picTemporär.Width = TransferGröße
    
    ' Die Winsock-Steuerelemente einstellen und eine Verbindung herstellen
    wskServer.LocalPort = BenutzterPort
    
    Call wskServer.Listen
    
    wskClient.LocalPort = BenutzterPort + 1
    wskClient.RemotePort = BenutzterPort
    wskClient.RemoteHost = "127.0.0.1"
    
    Call wskClient.Connect
    
    ' Den Timer initialisieren
    '  Alle zehntel Sekunde wird ein Teil des Bildes übertragen
    '  Dies dient nur der Veranschaulichung, wenn ein Bild
    '  schnell übertragen werden soll, sollte dies in einer
    '  Schleife geschehen
    ' Je niedriger das Intervall ist, desto eher passiert es,
    '  dass das Bild nicht komplett übertragen wird. Das
    '  Intervall sollte von daher zumindest bei ca. 15 ms
    '  liegen. Wie es in einer Schleife aussieht, müsste man
    '  gesondert testen.
    tmrÜbertragen.Interval = 100
    tmrÜbertragen.Enabled = False
    
    ' Die CommandButtons initialisieren
    cmdStart.Enabled = False
    cmdPause.Enabled = False
    
    ' "Zufallsgenerator" initialisieren
    Call Randomize(Timer)
    
    ' Array redimensionieren
    ReDim TeilBereitsÜbertragen(picQuelle.ScaleWidth / TransferGröße, _
        picQuelle.ScaleHeight / TransferGröße)
        
End Sub

Private Sub Form_Unload(Cancel As Integer)

    ' Aufräumen
    wskServer.Close
    wskClient.Close
    
    ' Warten, bis aufgeräumt wurde
    Do
    
        DoEvents
        
    Loop Until wskServer.State = sckClosed
    
End Sub

Private Sub tmrÜbertragen_Timer()

    ' Ein zufälliges Teil übertragen
    Call TeilÜbertragen
    
End Sub

Private Sub wskClient_Connect()

    ' Hinweis ausgeben
    Call NachrichtAusgeben("Verbindung hergestellt.")
    
End Sub

Private Sub wskClient_DataArrival(ByVal bytesTotal As Long)

    Dim Infos As New PropertyBag  ' Enthält Informationen über das
                                  ' gesendete Bild
    Dim ByteArray() As Byte       ' PropertyBags nehmen keine Strings an,
                                  ' deswegen der
                                  
    ' Umweg über ein ByteArray.
    Dim Data As String            ' Erhält die empfangenen Daten
    Dim X As Long, Y As Long      ' Erhalten die Positionsdaten
    
    ' Empfangene Daten holen
    Call wskClient.GetData(Data)
    
    ' Empfangene Daten in das ByteArray kopieren
    ByteArray = StrConv(Data, vbFromUnicode)
    
    ' Der Contents-Eigenschaft den Wert zuweisen
    Infos.Contents = ByteArray
    
    ' Um was für ein Daten-Paket handelt es sich?
    Select Case Infos.ReadProperty("Typ")
    
    Case "Start"   ' Anfängliche Daten
    
        ' Zielgröße auslesen
        picZiel.Width = Infos.ReadProperty("X")
        picZiel.Height = Infos.ReadProperty("Y")
        
        ' Temporäre Größe auslesen
        picTemporär.Width = Infos.ReadProperty("Größe")
        picTemporär.Height = Infos.ReadProperty("Größe")
        
        ' Hinweis ausgeben
        Call NachrichtAusgeben("Bildinformationen empfangen.")
        
    Case "Daten"   ' Bilddaten
    
        Set picTemporär.Picture = Infos.ReadProperty("Bild")
        
        X = Infos.ReadProperty("X")
        Y = Infos.ReadProperty("Y")
        
        ' Bildausschnitt kopieren
        Call BitBlt(picZiel.hDC, X, Y, TransferGröße, TransferGröße, _
            picTemporär.hDC, 0, 0, vbSrcCopy)
            
        ' Hinweis ausgeben
        Call NachrichtAusgeben("Bilddaten X=" & CStr(X) & ", Y=" & CStr(Y) & _
            " empfangen.")
            
    End Select
    
End Sub

Private Sub wskClient_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)
    
    ' Es ist ein Fehler aufgetreten...
    Call NachrichtAusgeben("Fehler: [" & CStr(Number) & "] " & Description)
    
End Sub

Private Sub TransferStarten()

    Dim Infos As New PropertyBag  ' Erhält Informationen über das zu
                                  ' sendende Bild
                                  
    ' Typ des Daten-Pakets speichern
    Call Infos.WriteProperty("Typ", "Start")
    
    ' X- und Y-Größe des Bildes speichern
    Call Infos.WriteProperty("X", picQuelle.ScaleWidth)
    Call Infos.WriteProperty("Y", picQuelle.ScaleHeight)
    
    ' Größe der Teilstücke speichern
    Call Infos.WriteProperty("Größe", TransferGröße)
    
    ' Informationen senden
    Call wskServer.SendData(StrConv(Infos.Contents, vbUnicode))
    
    ' Hinweis ausgeben
    Call NachrichtAusgeben("Bildinformationen gesendet.")
    
    ' Übertragung ermöglichen
    cmdStart.Enabled = True
    
End Sub

Private Sub TeilÜbertragen()

    Dim Infos As New PropertyBag  ' Erhält Informationen über den
                                  ' Bildausschnitt
    Dim X As Long, Y As Long      ' Erhalten Positionsinformationen
    Dim AlleÜbertragen As Boolean
    
    ' Positionsdaten zufällig wählen
    Do
    
        X = Round(Rnd() * picQuelle.ScaleWidth / TransferGröße, 0) * _
            TransferGröße
            
        Y = Round(Rnd() * picQuelle.ScaleHeight / TransferGröße, 0) * _
            TransferGröße
            
        ' DoEvents
    Loop While TeilBereitsÜbertragen(X / TransferGröße, Y / TransferGröße) _
        And Not chkLiveBild.Value = vbChecked
        
    TeilBereitsÜbertragen(X / TransferGröße, Y / TransferGröße) = True
    
    ' Bildausschnitt kopieren
    Call BitBlt(picTemporär.hDC, 0, 0, TransferGröße, TransferGröße, _
        picQuelle.hDC, X, Y, vbSrcCopy)
        
    ' Typ des Daten-Pakets speichern
    Call Infos.WriteProperty("Typ", "Daten")
    
    ' X- und Y-Position speichern
    Call Infos.WriteProperty("X", X)
    Call Infos.WriteProperty("Y", Y)
    
    ' Bilddaten speichern
    Call Infos.WriteProperty("Bild", picTemporär.Image)
    
    ' Informationen senden
    Call wskServer.SendData(StrConv(Infos.Contents, vbUnicode))
    
    ' Hinweis ausgeben
    Call NachrichtAusgeben("Bilddaten X=" & CStr(X) & ", Y=" & CStr(Y) & _
        " gesendet.")
        
    ' picTemporär löschen
    '  das dient nur dazu, zu beweisen, dass die Übertragung funktioniert.
    picTemporär.Cls
    
    ' ********************************************************************
    ' ***Der restliche Code muss weggelassen werden, wenn ein Live-Bild***
    ' ********** übertragen werden soll (bspw. von einer WebCam)**********
    ' ********************************************************************
    ' Handelt es sich um ein Live-Bild?
    If chkLiveBild.Value = vbChecked Then Exit Sub
    
    ' Wurden alle Teile übertragen?
    AlleÜbertragen = True
    
    For X = 0 To UBound(TeilBereitsÜbertragen, 1)
        For Y = 0 To UBound(TeilBereitsÜbertragen, 2)
        
            ' Diese zwei Schleifen suchen nach noch nicht übertragenen
            '  Teilen. Wurde eines gefunden, wird die Prozedur verlassen.
            '  Wird die Prozedur nicht verlassen, wurden also alle Teile
            '  übertragen. In diesem Falle wird eine Nachricht ausgegeben
            '  und der Timer deaktiviert.
            If Not TeilBereitsÜbertragen(X, Y) Then
            
                Exit Sub
                
            End If
            
            DoEvents
            
        Next Y
    Next X
    
    ' Alle Teile wurden übertragen.
    Call NachrichtAusgeben("Das Bild wurde komplett übertragen.")
    Call MsgBox("Das Bild wurde komplett übertragen.")
    
    tmrÜbertragen.Enabled = False
    cmdPause.Enabled = False
    cmdInfosSenden.Enabled = False
    
End Sub

Private Sub wskServer_ConnectionRequest(ByVal requestID As Long)

    ' Verbindung akzeptieren
    Call wskServer.Close
    Call wskServer.Accept(requestID)
    
    ' Hinweis ausgeben
    Call NachrichtAusgeben("Verbindungsaufbau...")
    
End Sub

Private Sub NachrichtAusgeben(Text As String)

    Dim Länge As Long    ' Die Länge des Textes vor dem hinzufügen.
    
    Länge = Len(txtEreignisse.Text)
    txtEreignisse.Text = txtEreignisse.Text & Text & vbCrLf
    
    ' Ist die Textbox voll?
    If Len(txtEreignisse.Text) < Länge + Len(Text) + Len(vbCrLf) Then
    
        ' Den Text in der Textbox löschen, einen entsprechenden Hinweis
        ' ausgeben
        '  und den Text erneut hinzufügen.
        ' Dieses Verfahren ist etwas umständlich, kommt dafür aber auch
        '  mit älteren Versionen der TextBox zurecht.
        txtEreignisse.Text = "Alte Ereignisse gelöscht" & vbCrLf & Text & _
            vbCrLf
            
    End If
    
    ' Einfügemarke ans Ende schieben, damit der Text mitscrollt
    txtEreignisse.SelStart = Len(txtEreignisse.Text)
    
End Sub

' ---- Ende Formular "frmTransfer" alias frmTransfer.frm  ----
' ------------ Ende Projektdatei BildTransfer.vbp ------------