Startseite / Tipps / VB 5/6-Tipp 0328: Nachrichten im Netzwerk versenden

VB 5/6-Tipp 0328: Nachrichten im Netzwerk versenden

 von Robert Albring

'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 Projektgruppe Gruppe1.vbg -------------
'---------- Anfang Projektdatei WinsockSender.vbp  ----------
' Die Komponente ' (MSWINSCK.OCX)' wird benötigt.

'----- Anfang Formular "Form1" alias WinsockSender.frm  -----
' Steuerelement: Rahmensteuerelement "Frame1"
' Steuerelement: Schaltfläche "cmdConn" auf Frame1
' Steuerelement: Schaltfläche "cmdDISC" auf Frame1
' Steuerelement: Textfeld "IP" auf Frame1
' Steuerelement: Beschriftungsfeld "Label1" auf Frame1
' Steuerelement: Textfeld "MTO"
' Steuerelement: Textfeld "MFROM"
' Steuerelement: Timersteuerelement "Timer1"
' Steuerelement: Windows Socket "Winsock1"
' Steuerelement: Textfeld "TXMESSAGE"
' Steuerelement: Schaltfläche "cmdSEND"
' Steuerelement: Beschriftungsfeld "Label3"
' Steuerelement: Beschriftungsfeld "lbl2"
' Steuerelement: Beschriftungsfeld "lbl1"
' Steuerelement: Beschriftungsfeld "RXMESSAGE"


'Autor: Robert Albring
'E-Mail: Robert.Albring@ReiseWelten.de

Option Explicit

Private Sub TXMESSAGE_Change()
    If MTO <> "" And TXMESSAGE <> "" Then
        cmdSEND.Enabled = True
    Else
        cmdSEND.Enabled = False
    End If
End Sub

Private Sub IP_Change()
    If MFROM <> "" And IP <> "" Then
        cmdConn.Enabled = True
    End If
End Sub

Private Sub MFROM_Change()
    If MFROM <> "" And IP <> "" Then
        cmdConn.Enabled = True
    End If
End Sub

Private Sub MTO_Change()
    If MTO <> "" And TXMESSAGE <> "" Then
        cmdSEND.Enabled = True
    Else
        cmdSEND.Enabled = False
    End If
End Sub

Private Sub Timer1_Timer()
    Timer1.Interval = 1000
    Caption = "WinsockSender - Status = " & Winsock1.State
End Sub

Private Sub cmdConn_Click()
    cmdDISC.Enabled = True
    cmdConn.Enabled = False
    MFROM.Enabled = False
    IP.Enabled = False
  
    Call conn
  
    If MTO <> "" And TXMESSAGE <> "" Then
        cmdSEND.Enabled = True
    End If
  
    MTO.Enabled = True
    TXMESSAGE.Enabled = True
    MTO.SetFocus
End Sub

Private Sub cmdSEND_Click()
    If Winsock1.State <> 7 Then conn
    SEND "1" & MFROM & "%" & MTO & "$" & TXMESSAGE
    RXMESSAGE = "Nachricht versendet"
End Sub

Private Sub cmdDISC_Click()
    cmdDISC.Enabled = False
    cmdConn.Enabled = True
    MFROM.Enabled = True
    IP.Enabled = True
  
    SEND "4" & MFROM
    DoEvents
  
    Winsock1.Close
  
    cmdSEND.Enabled = False
    MTO.Enabled = False
    TXMESSAGE.Enabled = False
End Sub

Sub SEND(Text As String)
    If Winsock1.State = 7 Then Winsock1.SendData Text
End Sub

Function conn()
    If Winsock1.State <> 0 Then Winsock1.Close
    
    Winsock1.Connect IP, 10567
      
    Do While Winsock1.State <> 7
        DoEvents
    Loop

    SEND "2" & MFROM
End Function

Private Sub Winsock1_DataArrival(ByVal bytesTotal As Long)
    Dim Message As String
  
    Winsock1.GetData Message
    RXMESSAGE = Message
    MsgBox Message
End Sub
'------ Ende Formular "Form1" alias WinsockSender.frm  ------
'----------- Ende Projektdatei WinsockSender.vbp  -----------
'-------------- Anfang Projektdatei MSERV.vbp  --------------
' Die Komponente 'Microsoft Windows Common Controls 6.0 (SP6) (mscomctl.ocx)' wird benötigt.
' Die Komponente ' (MSWINSCK.OCX)' wird benötigt.

'---- Anfang Formular "MailServer" alias MAILSERVER.frm  ----
' Steuerelement: Windows Socket "Winsock" (Index von 0 bis 0)
' Steuerelement: Listenanzeigesteuerungselement "User"
' Steuerelement: Listenanzeigesteuerungselement "LMessage"


'Autor: Robert Albring
'E-Mail: Robert.Albring@ ReiseWelten.de

Option Explicit

Private ID As Integer

Private Function WSend(i As Integer, Text As String)
    If Winsock(i).State = 7 Then
        Winsock(i).SendData Text
        
        Dim t As Long
        t = Timer
        
        Do While t + 0.5 > Timer
            DoEvents
        Loop
    End If
End Function

Private Sub Form_Load()
    If Winsock(0).State <> 0 Then Winsock(0).Close
    Winsock(0).LocalPort = 10567
    Winsock(0).Listen
End Sub

Private Sub Winsock_ConnectionRequest(Index As Integer, _
    ByVal requestID As Long)
    
    'Aktive User Setzen
  
    Dim i As Integer
START:
    
    For i = 1 To User.ListItems.Count
        User.ListItems.Item(i).SubItems(1) = _
            Winsock(User.ListItems.Item(i)).State
                     
        If User.ListItems.Item(i).SubItems(1) <> 7 Then
            Winsock(User.ListItems.Item(i)).Close
            Unload Winsock(User.ListItems.Item(i))
            User.ListItems.Remove i
            Goto START
        End If
    Next i

    'Verbinden
    If Index = 0 Then
        For i = 2 To User.ListItems.Count
            If User.ListItems(i) > User.ListItems(i - 1) + 1 Then
                Load Winsock(User.ListItems(i) - 1)
                Winsock(User.ListItems(i) - 1).LocalPort = 10567
                Winsock(User.ListItems(i) - 1).Accept requestID
                Exit Sub
            End If
        Next i
    
        If User.ListItems.Count > 0 Then
            If User.ListItems(1) >= 2 Then
                Load Winsock(User.ListItems(1) - 1)
                Winsock(User.ListItems(1) - 1).LocalPort = 10567
                Winsock(User.ListItems(1) - 1).Accept requestID
                Exit Sub
            End If
        
            Load Winsock(User.ListItems.Count + 1)
            Winsock(User.ListItems.Count + 1).LocalPort = 10567
            Winsock(User.ListItems.Count + 1).Accept requestID
            Exit Sub
        End If
      
        Load Winsock(1)
        Winsock(1).LocalPort = 0
        Winsock(1).Accept requestID
    End If
End Sub

Private Sub Winsock_DataArrival(Index As Integer, ByVal _
    bytesTotal As Long)
    
    'Aktive User Setzen
    Dim i As Integer
START:

    For i = 1 To User.ListItems.Count
        User.ListItems.Item(i).SubItems(1) = _
            Winsock(User.ListItems.Item(i)).State

        If User.ListItems.Item(i).SubItems(1) <> 7 Then
            Winsock(User.ListItems.Item(i)).Close
            Unload Winsock(User.ListItems.Item(i))
            User.ListItems.Remove i
            Goto START
        End If
    Next i

    'Nachricht Empfangen
    Dim Message As String
  
    Winsock(Index).GetData Message
    Call SetList(Mid(Message, 1, 1) & Index & Mid(Message, 2, _
        Len(Message)))
        
    If Mid(Message, 1, 1) = 4 Then Exit Sub

    'Nachricht Verteilen
    If Mid(Message, 1, 1) = 1 Then
        Dim MFrom As String, MTo As String, MText As String
        Dim ok As Integer
        
        MFrom = Mid(Message, 2, InStr(1, Message, "%") - 2)
        MTo = Mid(Message, InStr(1, Message, "%") + 1, _
                InStr(1, Message, "$") - InStr(1, Message, _
                "%") - 1)
                
        MText = Mid(Message, InStr(1, Message, "$") + 1, _
                  Len(Message))
        ok = 0
      
        For i = 1 To User.ListItems.Count
            If LCase(User.ListItems(i).SubItems(2)) = LCase(MTo) _
                Or LCase(MTo) = "alle" Then
          
                If LCase(User.ListItems(i).SubItems(2)) <> _
                    LCase(MFrom) Then
                    
                    WSend User.ListItems.Item(i), MText
                    SetList "3%" & User.ListItems(i).SubItems(2) _
                            & "$" & MText
                    ok = 1
                    Exit Sub
                End If
            End If
        Next i
        
        'User unbekannt
        If ok = 0 Then
            WSend Index, "User ist nicht aktiv"
            SetList "3%" & MFrom & "$" & "User ist nicht aktiv"
        End If
    End If
End Sub

Function SetList(Message As String)
    Dim litem As ListItem
  
    Select Case CInt(Mid(Message, 1, 1))

    Case 1, 4
        ID = ID + 1
        
        If LMessage.ListItems.Count > 13 Then _
            LMessage.ListItems.Remove 1
        
        Set litem = LMessage.ListItems.Add(, , ID)
        litem.SubItems(1) = Mid(Message, 3, InStr(1, Message, "%") - 3)
        litem.SubItems(2) = Mid(Message, InStr(1, Message, "%") + 1, _
            InStr(1, Message, "$") - InStr(1, Message, "%") - 1)
        
        litem.SubItems(3) = "<- " & Mid(Message, InStr(1, Message, "$") _
            + 1, Len(Message))

    Case 2
        Set litem = User.ListItems.Add(, , Mid(Message, 2, 1))
        
        litem.SubItems(1) = Winsock(CInt(Mid(Message, 2, 1))).State
        litem.SubItems(2) = Mid(Message, 3, Len(Message))
    
    Case 3
        If LMessage.ListItems.Count > 13 Then _
            LMessage.ListItems.Remove 1
            
        Set litem = LMessage.ListItems.Add(, , ID)
        litem.SubItems(1) = Mid(Message, 3, InStr(1, Message, "$") - 3)
        litem.SubItems(2) = "MailServer"
        litem.SubItems(3) = "<- " & Mid(Message, InStr(1, Message, "$") + _
            1, Len(Message))
    End Select
End Function
'----- Ende Formular "MailServer" alias MAILSERVER.frm  -----
'--------------- Ende Projektdatei MSERV.vbp  ---------------
'-------------- Ende Projektgruppe Gruppe1.vbg --------------

Tipp-Kompatibilität:

Windows/VB-Version	Win32s	Win95	Win98	WinME	WinNT4	Win2000	WinXP
VB4
VB5
VB6

Hat dieser Tipp auf Ihrem Betriebsystem und mit Ihrer VB-Version funktioniert?

Ja, funktioniert!

Nein, funktioniert nicht bei mir!

VB-Version: VB6 VB5 VB4

Windows-Version: Windows XP Windows 2000 Windows NT4 Windows Me Windows 98 Windows 95 Win32s

Archivierte Nutzerkommentare 

Klicken Sie diesen Text an, wenn Sie die 31 archivierten Kommentare ansehen möchten.
Diese stammen noch von der Zeit, als es noch keine direkte Forenunterstützung für Fragen und Kommentare zu einzelnen Artikeln gab.
Aus Gründen der Vollständigkeit können Sie sich die ausgeblendeten Kommentare zu diesem Artikel aber gerne weiterhin ansehen.