Chat personnel entre 2 personnes (im, message instantané).

Soyez le premier à donner votre avis sur cette source.

Vue 5 558 fois - Téléchargée 1 268 fois

Description

Source en vb6 d'un chat (IM, MP) personnel entre deux personnes, les deux doivent s'entendre sur les canneaux et avoir la même application, évidemment.

Source / Exemple :


'14/07/02 - 4/6/4 2.2
  'richard.kimble @ wanadoo.fr <- exemple d'origine
  '
  Private Declare Function SetWindowPos Lib "user32" _
    (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, _
    ByVal x As Long, ByVal y As Long, ByVal cx As Long, _
    ByVal cy As Long, ByVal wFlags As Long) As Long
  Dim Resultat As Long
  Const Flags = &H2 Or &H1 Or &H40 Or &H10
  '
  Option Explicit
  'espace disk libre
  Private Declare Function GetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" (ByVal lpRootPathName As String, SectorsPerCluster As Long, lpBytesPerSector As Long, lpNumberOfFreeClusters As Long, lpTotalNumberOfClusters As Long) As Long
  '
  Const SCAR = "|#sep#|" '  char de separation des paquets
  Dim People As String '   Pseudo de l'utilisateur connecte
  Dim MachinConnect As String '   adresse de la machine connectee
  Dim Oversion As String '  version de program connecte
  Dim FileName As String
  Dim Canal As Integer
  Dim Nre As Long
  Dim Nsoket As Boolean
  Dim Block As Variant   '   Archive
  Dim TransmitFichier As Boolean '  transmition en cour?
  Dim Connected As Boolean '  connection exist?

Sub Form_Initialize()
  TxtServeurName.Visible = False ' car position start "serveur"
  Label2.Visible = False
End Sub

Sub Form_Load()
  'toujours visible
  Resultat = SetWindowPos(FrmChat.hwnd, -1, 0, 0, 0, 0, Flags)
  MyAddress.Text = Winsock.LocalIP
  Call ActivCmdSend(False)
  Winsock.Protocol = sckTCPProtocol '  la connection se fera en tcp
  Connected = False
End Sub

Sub Command1_Click()
  If Command1.Caption = "Deconnexion" Then ' deconnecxion
      Call Wdisconnect '   deconnecter
      LblEtat.Caption = "Déconnecté"
    Else '   connection
      'il faut 1 pseudo pour se connecter
      If Len(MyPseudo.Text) = 0 Then
        MsgBox "Pseudonyme obligatoire", vbExclamation, "Connection"
        Exit Sub
      End If
      If (OptionServ(1).Value) And (Len(TxtServeurName.Text) = 0) Then
        MsgBox "Définition du serveur obligatoire", vbExclamation, "Connection"
        Exit Sub
        End If
        Call Wconnect '  connecter
  End If
End Sub

Sub Wconnect()
  TxtDialog = ""
  Winsock.Close
  Command1.Enabled = False
  If OptionServ(0).Value Then
    Winsock.LocalPort = TxtUsedPort.Text
    Winsock.Listen
    LblEtat.Caption = "En attente d'un client ..."
    Command1.Caption = "Deconnexion"
    Else
    Winsock.RemotePort = TxtUsedPort.Text
    Winsock.RemoteHost = TxtServeurName.Text
    LblEtat.Caption = "Connexion à " & TxtServeurName.Text & " en cours ..."
    TxtDialog = "CONNEXION ..."
    Dim Tent As Byte
    Dim Wt As Integer
    For Tent = 1 To 5
      TxtDialog = TxtDialog & vbCrLf & "  Tentative de connexion n°" & Tent
      Winsock.Close
      DoEvents
      Winsock.Connect
      For Wt = 0 To 10000
        DoEvents
        If Winsock.State = sckConnected Then Exit For
        Next
        If Winsock.State = sckConnected Then
          TxtDialog = TxtDialog & vbCrLf & "               Ok !" & vbCrLf
          Command1.Caption = "Deconnexion"
          Exit For
          Else
          TxtDialog = TxtDialog & vbCrLf & "               Echec !"
          End If
        Next
    End If
  Command1.Enabled = True
  End Sub
  

Sub Wdisconnect()
  Call ActivCmdSend(False)
  If Connected Then Winsock.SendData "<end>" & SCAR
  DoEvents
  Winsock.Close
  Connected = False
  LblEtat.Caption = "Déconnexion"
  Command1.Caption = "Connexion"
  End Sub

Sub Command2_Click()
  Dim SData As String
  SData = "prln>" & txtSending.Text
  Winsock.SendData SData & SCAR '   envoie le message en indiquant k'il est a afficher a la ligne
  TxtDialog = TxtDialog & vbCrLf & MyPseudo.Text & ">> " & txtSending.Text
  txtSending.Text = ""
  End Sub

Sub OptionServ_Click(Index As Integer)
  TxtServeurName.Enabled = OptionServ(1).Value
  If OptionServ(1).Value = False Then 'client
    TxtServeurName.Visible = False
    Label2.Visible = False
    End If
  If OptionServ(1).Value = True Then 'client
    TxtServeurName.Visible = True
    Label2.Visible = True
    End If
  End Sub

Sub TxtDialog_Change()
  TxtDialog.SelStart = Len(TxtDialog)
  End Sub

Sub txtSending_KeyPress(KeyAscii As Integer)
  If KeyAscii = 13 Then '   si la touche entrer est pressee
    Call Command2_Click ' on envoie le message
    KeyAscii = 0
    End If
  End Sub

Sub Winsock_ConnectionRequest(ByVal requestID As Long)
  If (Connected) Then
    Dim Mess As String
    Dim reponce As Integer
    Mess = "Un client souhaite se connecter." & vbCrLf & _
      "Si tu acceptes cette connection, l'ancienne sera coupee." & vbCrLf & _
      vbCrLf & "Accepter le nouveau client ?"
    reponce = MsgBox(Mess, vbYesNo + vbQuestion, "Connection")
    If reponce = vbYes Then
      Call Wdisconnect '  deconnect
      Else
      Exit Sub
      End If
    End If
    
  Winsock.Close '  precotion anti-erreur
  Winsock.Accept requestID '  la connection est acceptée
  Connected = True
  DoEvents
    
  Winsock.SendData "ifps>" & MyPseudo.Text & SCAR '  on envoie notre nom au client...
  Winsock.SendData "ifps?" & SCAR ' ...puis on lui demande le sien
  Winsock.SendData "ifad>" & MyAddress.Text & SCAR '  on envoie notre adresse
  Winsock.SendData "ifad?" & SCAR '  on demande son adresse au client
  Winsock.SendData "ifvs>" & App.Major & "." & App.Minor & "." & App.Revision & SCAR '  = mon adresse
  Winsock.SendData "ifvs?" & SCAR ' = adresse?
    
  Call ActivCmdSend(True) '  permetre a l'utilisateur d'envoyer
  End Sub

Sub Winsock_DataArrival(ByVal bytesTotal As Long)
  Dim vData As String
  Call Winsock.GetData(vData)  '  "capture" les donnes ki arrive
        
  Dim Pso As Long
  Dim strPack As String
  Pso = InStr(1, vData, SCAR)
    
  Do While Pso > 0
    strPack = Left(vData, Pso - 1)
    DoEvents
    vData = Right(vData, Len(vData) - Len(strPack) - Len(SCAR))
    If Len(strPack) >= 5 Then Call TraitPack(strPack) '  analyse le paquet
    Pso = InStr(1, vData, SCAR)
    Loop
  End Sub
    
    
Sub TraitPack(strData As String)
  Dim LeftData As String * 5
  LeftData = Left(strData, 5) '   infos detinnees a l'application
  strData = Right(strData, Len(strData) - 5) '  donnees
    
  Select Case LeftData
    Case "prln>" '  les donnees sont a afficher a la ligne
    TxtDialog = TxtDialog & vbCrLf & People & ">> " & strData
        
    Case "prnx>" '   les donnees sont a afficher a la suite
    TxtDialog = TxtDialog & strData
        
    Case "ifps>" '   C le pseudo du mec connecte
    People = strData
    LblEtat.Caption = "Connecté avec " & strData
    Connected = True '  si on recoit le nom de la personne connectee C k'il y a connection
    Call ActivCmdSend(True)
                
    Case "ifps?" '   = kel est ton nom?
    Winsock.SendData "ifps>" & MyPseudo.Text & SCAR '   on lui reponds gentillement
        
    Case "ifad>" '   C l'adresse de la machine connectee
    MachinConnect = strData
    Text1 = " IP vis-à-vis  " & MachinConnect 'joé
        
    Case "ifad?" '  = kel est ton adresse?
    Winsock.SendData "ifad>" & MyAddress.Text & SCAR '   on envoie la reponce
        
    Case "ifvs>" ' version du program connecte
    Oversion = strData
        
    Case "ifvs?" '  = kel est ta version?
    Winsock.SendData "ifvs>" & App.Major & "." & App.Minor & "." & App.Revision & SCAR
        
    Case "<end>" '   la connection est finie
    Connected = False
    Call Wdisconnect
    LblEtat.Caption = People & " a mit fin a la connection."
        
    Case Else '  donnees inconnues
    On Error Resume Next
    TxtDialog = TxtDialog & vbCrLf & "ERREUR :    Command inconnue!"
    If Err <> 0 Then TxtDialog = ""
    End Select
  End Sub

Function Unarch(Paquet As Long) As String
  Dim Pcur As Long
  Dim Pq As Long
  Pcur = InStr(1, Block, SCAR & CStr(Paquet))
  If Pcur = 0 Then
    Unarch = ""
    Else
    Pq = InStr(Pcur, Block, SCAR)
    Unarch = Mid(Block, Pcur + Len(SCAR))
    End If
  End Function

Sub ActivCmdSend(Etat As Boolean)
  txtSending.Enabled = Etat
  Command2.Enabled = Etat
  End Sub

Sub m_aide_Click()
  Dim ligne As String
  '
  Frame1.Visible = False
  Frame2.Visible = False
  LblEtat.Visible = False
  TxtDialog.Visible = False
  txtSending.Visible = False
  Command2.Visible = False
  FrmChat.ScaleMode = 1
  Text2 = ""
  Text2.Top = 120
  Text2.Left = 120
  Text2.Height = 5800 '5575
  Text2.Width = 6375
  '
  ligne = "WINSOCK CHAT" & vbCrLf & vbCrLf
  ligne = ligne & "Concepteur: Joseph Attila PUSZTAY" & vbCrLf & vbCrLf
  ligne = ligne & "Version 1.1 2002-2004" & vbCrLf & vbCrLf & vbCrLf
  ligne = ligne & "Ce logiciel à pour but de permettre la liaison par Internet entre deux ordinateurs distants (Chat), afin de réaliser une correspondance écrite en directe." & vbCrLf & vbCrLf
  ligne = ligne & "Vous êtes soit client, soit serveur." & vbCrLf
  ligne = ligne & "Le principe est que le serveur se connecte et attend la connexion de son client." & vbCrLf & vbCrLf
  ligne = ligne & "Si vous êtes serveur:" & vbCrLf
  ligne = ligne & "-1- Vous communiquez votre adresse IP et le canal choisi à votre correspondant:" & vbCrLf
  ligne = ligne & "-2- Choisir un pseudonyme" & vbCrLf
  ligne = ligne & "-3- Votre adresse IP s'inscrit automatiquement." & vbCrLf
  ligne = ligne & "-4- Vous verrez à la connexion l'adresse IP de votre correspondant, ainsi que l'état de la liaison dans la barre de titre de la zone des textes." & vbCrLf
  ligne = ligne & "-5- cocher (o)serveur." & vbCrLf
  ligne = ligne & "-6- Indiquer le port de connexion choisi." & vbCrLf
  ligne = ligne & "-7- Valider la <connexion> qui va se mettre en attente." & vbCrLf & vbCrLf
  ligne = ligne & "Si vous êtes client:" & vbCrLf & vbCrLf
  ligne = ligne & "-1- Demandez l'adresse IP et le canal choisi à votre correspondant:" & vbCrLf
  ligne = ligne & "-2- Choisir un pseudonyme." & vbCrLf
  ligne = ligne & "-3- Votre adresse IP s'inscrit automatiquement." & vbCrLf
  ligne = ligne & "-4- Vous verrez à la connexion l'adresse IP de votre correspondant, ainsi que l'état de la liaison dans la barre de titre de la zone des textes." & vbCrLf
  ligne = ligne & "-5- cocher (o)client." & vbCrLf
  ligne = ligne & "-6- Saisissez l'adresse IP de votre correspondant." & vbCrLf
  ligne = ligne & "-7- Indiquer le port de connexion choisi." & vbCrLf
  ligne = ligne & "-8- Valider la <connexion> qui va se mettre en attente." & vbCrLf & vbCrLf
  ligne = ligne & "Une fois la liaison établie:" & vbCrLf
  ligne = ligne & "-1- Rédiger dans la zone du bas votre texte." & vbCrLf
  ligne = ligne & "-2- Valider l'envoi de votre rédaction par le bouton <Envoyer>." & vbCrLf
  ligne = ligne & "-3- Votre message précédé de votre pseudo v'a s'afficher dans la zone des textes de correspondance." & vbCrLf
  ligne = ligne & "-4- C'est à votre correspondant de répondre, ou à vous de compléter, etc..." & vbCrLf & vbCrLf
  ligne = ligne & "Mettre fin à la connexion:" & vbCrLf
  ligne = ligne & "Il suffit que l'un des deux correspondants ferme son programme." & vbCrLf & vbCrLf
  ligne = ligne & "Observations:" & vbCrLf
  ligne = ligne & "Des canaux sont réservé pour certains échanges (emails, news-groups), les laisser libre (vous renseigner sur Internet concernant les ports réservés), ce qui dans l'absolu, quel que soit le port de correspondance (identique entre les deux), n'interdit pas la correspondance mais peut ralentir d'autre connexions, comme le courrier..." & vbCrLf
  ligne = ligne & "Si vous avez des antivirus actifs, ou coupes feux, autoriser la communication..."
  Text2 = ligne
  Text2.Visible = True
End Sub

Sub m_fermer_aide_Click()
  Text2.Visible = False
  Frame1.Visible = True
  Frame2.Visible = True
  LblEtat.Visible = True
  TxtDialog.Visible = True
  txtSending.Visible = True
  Command2.Visible = True
End Sub

Sub Form_Unload(Cancel As Integer)
  'n'est plus toujours visible
  Resultat = SetWindowPos(FrmChat.hwnd, -2, 0, 0, 0, 0, Flags)
  If Connected Then Call Wdisconnect
  Winsock.Close
  End
End Sub

Conclusion :


A été testé jadis sous Windows 98 et fonctionne sans problème...

Codes Sources

A voir également

Ajouter un commentaire

Commentaires

cs_clementpat
Messages postés
406
Date d'inscription
lundi 2 décembre 2002
Statut
Membre
Dernière intervention
25 janvier 2014
-
Tres bien , je vais me pencher sur le code car je ne connais pas la fonction chat en vb .
Merci
cs_Jack
Messages postés
14008
Date d'inscription
samedi 29 décembre 2001
Statut
Modérateur
Dernière intervention
28 août 2015
60 -
Mauvaise indentation du code qui le rend difficile à lire.
Dans Wconnect(), très compliqué de comprendre à quoi servent les boucles avec ce genre d'indentation.
For Wt 0 To 10000 Horrible!
D'une part parce que cette boucle peut représenter des temps tout à fait variables en fonction des machines, mais aussi parce que ce n'est pas propre.
Do While Winsock.State = sckConnecting
DoEvents
Loop
If Winsock.State = sckConnected Then
' Ok
Else
' Pas Ok
End If

Si le message reçu est long (ou réseau super-surchargé ou machine super-rapide), il y a de fortes chance d'en perdre des morceaux :
Dans DataArrival, tu stockes les données arrivées dans vData.
Si SCAR n'est pas repéré dans les données, tu ressorts de la Sub en perdant les données, alors que la suite arrivera au prochain arrivage, mais on aura perdu le début !

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.