VB.NET-Tipp 0149: Versuchs-Chat
von Spatzenkanonier
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: | Framework-Version(en): .NET Framework 3.0, .NET Framework 3.5, .NET Framework 4 | .NET-Version(en): Visual Basic 2008, Visual Basic 2010 | Download: |
' 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.