Die Community zu .NET und Classic VB.
Menü

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

 von 

Beschreibung 

Wenn man ein Bild übertragen möchte, denkt man zunächst an die Möglichkeit, es zu speichern, die Datei auszulesen, zu verschicken, die Datei wieder zu schreiben und dann anzuzeigen.

Dass es mithilfe des PropertyBag-Objekts wesentlich einfacher geht, zeigt dieser Tipp. Er eignet sich auch, um Bilder, die per WebCam auf einem Formular/Einer PictureBox angezeigt werden, zu übertragen.

Schwierigkeitsgrad:

Schwierigkeitsgrad 2

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 ------------

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.