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

Télécharger le projet
Commenter

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...
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

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.

Du même auteur (ehjoe)