Die Community zu .NET und Classic VB.
Menü

VB.NET-Tipp 0149: Versuchs-Chat

 von 

Beschreibung

Mikro-Chat von zweifelhafter Sinnhaftigkeit (man muss sich zum Chatten telefonisch die IPs mitteilen). Gezeigt wird jedoch der Umgang mit den Klassen TCPListener, TCPClient und NetworkStream unter Einsatz asynchroner Aufrufe, um die Hauptanwendung nicht zu blockieren.

Schwierigkeitsgrad:

Schwierigkeitsgrad 3

Framework-Version(en):

.NET Framework 3.0, .NET Framework 3.5, .NET Framework 4

.NET-Version(en):

Visual Basic 2008, Visual Basic 2010

Download:

Download des Beispielprojektes [18 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!

' Projektversion:   Visual Studio 2005
' Option Strict:    An
' Option Infer:     An
'
' Referenzen: 
'  - System
'  - System.Data
'  - System.Deployment
'  - System.Drawing
'  - System.Windows.Forms
'  - System.Xml
'
' Imports: 
'  - Microsoft.VisualBasic
'  - Microsoft.VisualBasic.ControlChars
'  - System
'  - System.Collections
'  - System.Collections.Generic
'  - System.Data
'  - System.Drawing
'  - System.Diagnostics
'  - System.Windows.Forms
'

' ##############################################################################
' ################################# Client.vb ##################################
' ##############################################################################
Imports System.Net
Imports System.Net.Sockets
Imports System.Text

Public Class Client : Inherits TCPBase

    Private _TcpClient As TcpClient
    Private _Stream As NetworkStream
    Dim Buf(&H400 - 1) As Byte

    Public Sub New(ByVal TC As TcpClient)
        _TcpClient = TC
        _Stream = _TcpClient.GetStream
        _Stream.BeginRead(Buf, 0, Buf.Length, AddressOf EndRead, Nothing)
    End Sub

    Private Sub EndRead(ByVal ar As IAsyncResult)
        If MyBase.IsDisposed Then Return
        Dim read As Integer = _Stream.EndRead(ar)
        If read = 0 Then 'leere Datenübermittlung signalisiert Verbindungsabbruch
            CrossThread.RunGui(AddressOf OnStatusMessage, _
                               New MessageEventargs("CounterClient shut down"))
            CrossThread.RunGui(AddressOf MyBase.Dispose)
            Return
        End If
        Dim SB As New StringBuilder(Encoding.UTF8.GetString(Buf, 0, read))
        Do While _Stream.DataAvailable
            read = _Stream.Read(Buf, 0, Buf.Length)
            SB.Append(Encoding.UTF8.GetString(Buf, 0, read))
        Loop
        CrossThread.RunGui(AddressOf OnChatMessage, _
                           New MessageEventargs(SB.ToString))
        _Stream.BeginRead(Buf, 0, Buf.Length, AddressOf EndRead, Nothing)
    End Sub

    Public Overrides Sub Send(ByVal Msg As String)
        Dim Buf() As Byte = Encoding.UTF8.GetBytes(Msg)
        _Stream.Write(Buf, 0, Buf.Length)
    End Sub

    Protected Overrides Sub Dispose(ByVal disposing As Boolean)
        DisposeAll(_Stream, _TcpClient)
    End Sub

End Class

' ##############################################################################
' ############################## CrossThread.vb ################################
' ##############################################################################
' VB2008 hat diese 3 generischen Delegaten bereits deklariert - daher sollten 
'  sie bei Verwendung von VB2008 nicht noch einmal deklariert werden.
#Region "Delegaten"
Public Delegate Sub Action()
Public Delegate Sub Action(Of T1, T2)(ByVal Arg1 As T1, _
                                      ByVal Arg2 As T2)
Public Delegate Sub Action(Of T1, T2, T3)(ByVal Arg1 As T1, _
                                          ByVal Arg2 As T2, _
                                          ByVal Arg3 As T3)
#End Region

''' <summary>
''' Stellt Methoden bereit, mit denen ein beliebiger Methoden-Aufruf mit bis zu 
'''  drei Argumenten in einen Nebenthread verlegt werden kann, bzw. aus einem 
'''  Nebenthread in den Hauptthread.
''' </summary>
Public Class CrossThread

    Public Shared Sub RunAsync(Of T1, T2, T3)( _
            ByVal Action As Action(Of T1, T2, T3), _
            ByVal Arg1 As T1, _
            ByVal Arg2 As T2, _
            ByVal Arg3 As T3)

        ' Aufruf von Action.EndInvoke() gewährleisten, indem er als 
        '  Callback-Argument mitgegeben wird
        Action.BeginInvoke(Arg1, Arg2, Arg3, _
                           AddressOf Action.EndInvoke, Nothing)
    End Sub
    Public Shared Sub RunAsync(Of T1, T2)(ByVal Action As Action(Of T1, T2), _
                                          ByVal Arg1 As T1, ByVal Arg2 As T2)
        Action.BeginInvoke(Arg1, Arg2, AddressOf Action.EndInvoke, Nothing)
    End Sub
    Public Shared Sub RunAsync(Of T1)(ByVal Action As Action(Of T1), _
                                      ByVal Arg1 As T1)
        Action.BeginInvoke(Arg1, AddressOf Action.EndInvoke, Nothing)
    End Sub
    Public Shared Sub RunAsync(ByVal Action As Action)
        Action.BeginInvoke(AddressOf Action.EndInvoke, Nothing)
    End Sub

    Private Shared Function GuiCrossInvoke(ByVal Action As [Delegate], _
            ByVal ParamArray Args() As Object) As Boolean

        If Application.OpenForms.Count = 0 Then
            ' Wenn kein Form mehr da ist, so tun, als ob das Invoking 
            '  ausgeführt wäre
            Return True
        End If
        If Application.OpenForms(0).InvokeRequired Then
            Application.OpenForms(0).BeginInvoke(Action, Args)
            Return True
        End If
    End Function

    Public Shared Sub RunGui(Of T1, T2, T3)( _
            ByVal Action As Action(Of T1, T2, T3), _
            ByVal Arg1 As T1, _
            ByVal Arg2 As T2, _
            ByVal Arg3 As T3)

        ' Falls Invoking nicht erforderlich, die Action direkt ausführen
        If Not GuiCrossInvoke(Action, Arg1, Arg2, Arg3) Then
            Action(Arg1, Arg2, Arg3)
        End If
    End Sub
    Public Shared Sub RunGui(Of T1, T2)(ByVal Action As Action(Of T1, T2), _
                                        ByVal Arg1 As T1, ByVal Arg2 As T2)
        If Not GuiCrossInvoke(Action, Arg1, Arg2) Then Action(Arg1, Arg2)
    End Sub
    Public Shared Sub RunGui(Of T1)(ByVal Action As Action(Of T1), _
                                    ByVal Arg1 As T1)
        If Not GuiCrossInvoke(Action, Arg1) Then Action(Arg1)
    End Sub
    Public Shared Sub RunGui(ByVal Action As Action)
        If Not GuiCrossInvoke(Action) Then Action()
    End Sub

End Class

' ##############################################################################
' ################################ frmMain.vb ##################################
' ##############################################################################
Imports System.Net
Imports System.Net.Sockets

''' <summary>
''' Dieses Form kann sowohl als Server-Anwendung laufen, als auch als 
'''  Client-Anwendung.
''' </summary>
Public Class frmMain

    Private WithEvents _ServerOrClient As TCPBase 'polymorphes Objekt

    Public Sub New()
        InitializeComponent()
        With Application.OpenForms 'bei mehreren Instanzen versetzt anordnen
            If .Count > 0 Then
                Me.Location = .Item(.Count - 1).Location + New Size(30, 50)
            Else
                Me.Location = Screen.PrimaryScreen.WorkingArea.Location
            End If
        End With
    End Sub

    Private Sub MenuItem_Click(ByVal sender As Object, ByVal e As EventArgs) _
            Handles SendMessageToolStripMenuItem.Click, _
                AddFormToolStripMenuItem.Click, _
                BeServerToolStripMenuItem.Click, _
                BeClientToolStripMenuItem.Click, _
                TestToolStripMenuItem.Click
        Select Case True
            Case sender Is SendMessageToolStripMenuItem
                If _ServerOrClient Is Nothing Then
                    DisplayStatusLine("Fehler:", Lf, "keine Verbindung")
                Else
                    _ServerOrClient.Send(Me.rtbSend.Text)
                End If

            Case sender Is AddFormToolStripMenuItem
                Call (New frmMain()).Show(Me)

            Case sender Is BeServerToolStripMenuItem
                DisposeAll(_ServerOrClient)
                Dim EP As IPEndPoint = GetEP()
                If EP Is Nothing Then Return
                _ServerOrClient = New Server(EP)
                DisplayStatusLine("Hi!", Lf, "Ich bin Server, höre auf:", _
                                  Lf, EP)
                Me.Text = "Server"

            Case sender Is BeClientToolStripMenuItem
                DisposeAll(_ServerOrClient)
                Dim EP As IPEndPoint = GetEP()
                If EP Is Nothing Then Return
                ' Sehr ärgerlich: der TcpClient-Konstruktor New(EP as IPEndPoint)
                '  produziert auf Einzelplatzsystemen einen unnötigen Fehler, 
                '  weil er  (undokumentiert!) TcpClient.ExclusiveAddressUse=True 
                '  voreinstellt. 
                Dim TC As New TcpClient
                TC.ExclusiveAddressUse = False
                Try
                    TC.Connect(EP)
                Catch ex As Exception
                    TC.Close()
                    DisplayStatusLine("Fehler:", Lf, ex.Message)
                    Return
                End Try
                _ServerOrClient = New Client(TC)
                DisplayStatusLine("Hi!", Lf, "Client, verbunden mit:", Lf, EP)
                Me.Text = "Client"

            Case sender Is TestToolStripMenuItem

        End Select
    End Sub

    ' Diese Sub ist normalerweise in der Designer.vb. Wir wollen jedoch
    '  sicherstellen, das _ServerOrClient *vor* den Koponenten disposed wird. 
    '  Sonst werden womöglich noch Daten empfangen, und entsteht ein Fehler 
    '  beim Darstellen.
    Protected Overrides Sub Dispose(ByVal disposing As Boolean)
        DisposeAll(_ServerOrClient)
        If disposing AndAlso components IsNot Nothing Then
            components.Dispose()
        End If
        MyBase.Dispose(disposing)
    End Sub

#Region "ServerOrClient-Ereignisverarbeitung"

    Private Sub ServerOrClient_ChatMessage(ByVal Sender As Object, _
            ByVal e As MessageEventargs) Handles _ServerOrClient.ChatMessage

        DisplayLine(e.Message)
    End Sub

    Private Sub _ServerOrClient_Disposed(ByVal Sender As TCPBase) _
            Handles _ServerOrClient.Disposed
        _ServerOrClient = Nothing
        Me.Text = "Offline"
    End Sub

    Private Sub ServerOrClient_StatusMessage(ByVal Sender As Object, _
            ByVal e As MessageEventargs) Handles _ServerOrClient.StatusMessage

        DisplayStatusLine(e.Message)
    End Sub

#End Region 'ServerOrClient-Ereignisverarbeitung

    Private Function GetEP() As IPEndPoint
        Dim DefaultIP As String = ""
        Dim addresses As IPAddress() = _
            Dns.GetHostEntry(My.Computer.Name).AddressList
        If addresses.Length = 1 Then DisplayStatusLine("Sie sind Offline!")
        Array.Reverse(addresses)
        For Each addr As IPAddress In addresses
            If addr.AddressFamily = AddressFamily.InterNetwork Then
                DefaultIP = String.Concat(addr, " : 12345")
                Exit For
            End If
        Next
        Dim InputIP As String = InputBox( _
           "(voreingestellt: eigene IP und willkürlicher Port)", _
           "IP eingeben", _
           DefaultIP)
        Try
            Dim Splitted As String() = InputIP.Split(":"c)
            Dim IPAs As IPAddress() = Dns.GetHostAddresses(Splitted(0))
            Return New IPEndPoint(IPAs(0), Integer.Parse(Splitted(1)))
        Catch ex As Exception
            DisplayStatusLine("Die IP '", InputIP, _
                              "' konnte nicht aufgelöst werden")
            Return Nothing
        End Try
    End Function

    Private Sub DisplayLine(ByVal Msg As String)
        Me.rtbLog.AppendText(Msg & Lf)
    End Sub

    ''' <summary>Meldung hellgelb hinterlegt anzeigen</summary>
    Private Sub DisplayStatusLine(ByVal ParamArray Items() As Object)
        Static StatusLineColor As Color = Color.FromArgb(255, 255, 200)
        Me.rtbLog.SelectionBackColor = StatusLineColor
        DisplayLine(String.Concat(Items))
        Me.rtbLog.SelectionBackColor = Color.White
    End Sub

End Class
' ##############################################################################
' ############################ MessageEventargs.vb #############################
' ##############################################################################
Public Class MessageEventargs : Inherits EventArgs
    Public ReadOnly Message As String

    Public Sub New(ByVal ParamArray Segments() As Object)
        MyBase.New()
        Me.Message = String.Concat(Segments)
    End Sub
End Class
' ##############################################################################
' ############################### modHelpers.vb ################################
' ##############################################################################
Public Module modHelpers

    ''' <summary>
    ''' Eventhandler, der den Sender ordentlich typisiert übermittelt
    ''' </summary>
    Public Delegate Sub EventHandlerEx(Of T0)(ByVal Sender As T0)

    Public Sub DisposeAll(ByVal ParamArray Disposables As IDisposable())
        For Each D As IDisposable In Disposables
            If D IsNot Nothing Then D.Dispose()
        Next
    End Sub

End Module

' ##############################################################################
' ################################# Server.vb ##################################
' ##############################################################################
Imports System.Net
Imports System.Net.Sockets

Public Class Server : Inherits TCPBase

    Private _Listener As TcpListener

    ' Pro Verbindung(sanfrage) wird ein Client-Objekt generiert, das den 
    '  Datenaustausch dieser Verbindung abwickelt
    Private _Clients As New List(Of Client)

    Public Sub New(ByVal EP As IPEndPoint)
        _Listener = New TcpListener(EP)
        _Listener.ExclusiveAddressUse = False
        _Listener.Start()
        _Listener.BeginAcceptTcpClient(AddressOf EndAccept, Nothing)
    End Sub

    Sub EndAccept(ByVal ar As IAsyncResult)
        If MyBase.IsDisposed Then Return
        With New Client(_Listener.EndAcceptTcpClient(ar))
            AddHandler .ChatMessage, AddressOf Client_ChatMessage
            AddHandler .StatusMessage, AddressOf Client_StatusMessage
            AddHandler .Disposed, AddressOf Client_Disposed
            .AddTo(_Clients)
        End With
        CrossThread.RunGui(AddressOf OnStatusMessage, _
                           New MessageEventargs("TCPClient accepted"))
        _Listener.BeginAcceptTcpClient(AddressOf EndAccept, Nothing)
    End Sub

#Region "_Clients-Ereignisverarbeitung"

    Private Sub Client_Disposed(ByVal Sender As TCPBase)
        ' Den Client für die beendete Verbindung entfernen
        Sender.RemoveFrom(_Clients)
    End Sub

    Private Sub Client_ChatMessage(ByVal sender As Object, _
                                   ByVal e As MessageEventargs)
        ' Einkommende ChatMessages anzeigen, und an alle versenden
        Send(e.Message)
    End Sub

    Private Sub Client_StatusMessage(ByVal sender As Object, _
                                     ByVal e As MessageEventargs)
        ' Einkommende StatusMessages durchreichen (zur Anzeige)
        OnStatusMessage(e)
    End Sub

#End Region '_Clients-Ereignisverarbeitung

    Public Overrides Sub Send(ByVal Msg As String)
        OnChatMessage(New MessageEventargs(Msg)) ' anzeigen
        For Each C As Client In _Clients    ' an alle versenden
            C.Send(Msg)
        Next
    End Sub

    Protected Overrides Sub Dispose(ByVal disposing As Boolean)
        _Listener.Stop()
        For i = _Clients.Count - 1 To 0 Step -1
            _Clients(i).Dispose()
        Next
    End Sub

End Class

' ##############################################################################
' ################################ TCPBase.vb ##################################
' ##############################################################################
Imports System.Net.Sockets
Imports System.Threading

''' <summary>
'''  Stellt den Erben "Server" und "Client" 2 verschiedene
'''   Message-Events zur Verfügung und ein Event-Raisendes Dispose.
''' </summary>
Public MustInherit Class TCPBase : Implements IDisposable

    Private _IsDisposed As Boolean = False
    Public Event Disposed As EventHandlerEx(Of TCPBase)

    Protected MustOverride Sub Dispose(ByVal disposing As Boolean)
    Public MustOverride Sub Send(ByVal Msg As String)

    ''' <summary>
    ''' Zur Ausgabe chat-verwaltungstechnischer Status-Informationen
    ''' </summary>
    Public Event StatusMessage As EventHandler(Of MessageEventargs)
    Protected Sub OnStatusMessage(ByVal e As MessageEventargs)
        RaiseEvent StatusMessage(Me, e)
    End Sub

    ''' <summary>Zur Ausgabe von Chat-Messages</summary>
    Public Event ChatMessage As EventHandler(Of MessageEventargs)
    Protected Sub OnChatMessage(ByVal e As MessageEventargs)
        RaiseEvent ChatMessage(Me, e)
    End Sub

    Public Sub RemoveFrom(Of T As TCPBase)(ByVal Coll As ICollection(Of T))
        Coll.Remove(DirectCast(Me, T))
    End Sub

    Public ReadOnly Property IsDisposed() As Boolean
        Get
            Return _IsDisposed
        End Get
    End Property


    Public Sub AddTo(Of T As TCPBase)(ByVal Coll As ICollection(Of T))
        Coll.Add(DirectCast(Me, T))
    End Sub

    Public Sub Dispose() Implements IDisposable.Dispose
        If _IsDisposed Then Return
        _IsDisposed = True
        ' Rufe die erzwungenen Überschreibungen von Sub Dispose(Boolean) auf
        Dispose(True)
        OnStatusMessage(New MessageEventargs(Me.GetType.Name, " disposed"))
        RaiseEvent Disposed(Me)
        GC.SuppressFinalize(Me)
    End Sub

End Class

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.