bfcc.frm

VB 编写 初学者可以拿去做研究 支持源码开发

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form Form1 
   Caption         =   "BFChat - Client"
   ClientHeight    =   6015
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9060
   LinkTopic       =   "Form1"
   ScaleHeight     =   6015
   ScaleWidth      =   9060
   StartUpPosition =   3  'Windows Default
   Begin VB.Timer Timer1 
      Interval        =   8000
      Left            =   7560
      Top             =   4440
   End
   Begin VB.TextBox nam 
      Height          =   285
      Left            =   6240
      TabIndex        =   10
      Top             =   3960
      Width           =   1815
   End
   Begin VB.TextBox host 
      Enabled         =   0   'False
      Height          =   285
      Left            =   6240
      TabIndex        =   9
      Top             =   3360
      Width           =   1815
   End
   Begin VB.TextBox myip 
      Enabled         =   0   'False
      Height          =   285
      Left            =   6240
      TabIndex        =   7
      Top             =   2640
      Width           =   1815
   End
   Begin MSWinsockLib.Winsock ws 
      Left            =   7920
      Top             =   4440
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.CommandButton connect 
      Caption         =   "连接"
      Height          =   615
      Left            =   6360
      TabIndex        =   5
      Top             =   720
      Width           =   1815
   End
   Begin VB.TextBox Server 
      Height          =   285
      Left            =   6360
      TabIndex        =   3
      Top             =   240
      Width           =   1815
   End
   Begin VB.TextBox sayt 
      Height          =   285
      Left            =   15
      TabIndex        =   2
      Top             =   4890
      Width           =   5175
   End
   Begin VB.CommandButton say 
      Caption         =   "发送"
      Height          =   315
      Left            =   5280
      TabIndex        =   1
      Top             =   4875
      Width           =   930
   End
   Begin VB.TextBox talk 
      Height          =   4455
      Left            =   0
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   0
      Width           =   6135
   End
   Begin VB.Label Status 
      Height          =   255
      Left            =   600
      TabIndex        =   12
      Top             =   4920
      Width           =   4695
   End
   Begin VB.Label Label4 
      Caption         =   "聊天者:"
      Height          =   255
      Left            =   6240
      TabIndex        =   11
      Top             =   3720
      Width           =   855
   End
   Begin VB.Label Label3 
      Caption         =   "本机名称:"
      Height          =   255
      Left            =   6240
      TabIndex        =   8
      Top             =   3120
      Width           =   1215
   End
   Begin VB.Label Label2 
      Caption         =   "本机IP:"
      Height          =   255
      Left            =   6240
      TabIndex        =   6
      Top             =   2400
      Width           =   495
   End
   Begin VB.Label Label1 
      Caption         =   "服务端IP:"
      Height          =   255
      Left            =   6360
      TabIndex        =   4
      Top             =   0
      Width           =   735
   End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'客户端软件
'author 曹万军
'修改的别人的程序
'
'


Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal _
        HostName$, ByVal HostLen%) As Long      '指明包含所声明过程的动态链接库WSOCK32.DLL
        
Private Declare Function gethostbyname Lib "WSOCK32.DLL" _
        (ByVal HostName$) As Long
        

Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As _
        Any, ByVal hpvSource&, ByVal cbCopy&)

'定义常量

Const SOCKET_ERROR = -1

'自定义类型
Private Type HostDeType
  hName As Long
  hAliases As Long
  hAddrType As Integer
  hLength As Integer
  hAddrList As Long
End Type

'定义四个变量
Dim justtext  As String
Dim dat As String
Dim justc As Integer
Dim justd As Integer
'连服务器
Private Sub connect_Click()
ws.Close

ws.connect Server.Text, 316     '端口号为316 自己的端口号为317
connect.Enabled = False
Server.Enabled = False

End Sub

'先执行这里
Private Sub Form_Load()
Status.Caption = "开始"
Timer1.Enabled = False
say.Enabled = False

host.Text = MyHostName       'computername
myip.Text = HostByName(MyHostName)  'computerIp
End Sub

'可以多次连接  重点
Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
If ws.State = sckConnected Then
Cancel = 1
ws.SendData "IgogogoNOW!!!"
justd = 2
End If
If ws.State = sckConnecting Then
Cancel = 1
MsgBox "Please try again closing the program in a few seconds!" + vbNewLine + "Just connecting to server!"
End If
If ws.State = sckListening Then
Cancel = 1
MsgBox "Please try again closing the program in a few seconds!" + vbNewLine + "Just connecting to server!"
End If
End Sub

'发送消息，清空

Private Sub say_Click()

ws.SendData sayt.Text
sayt.Text = ""
End Sub
 
 '显示消息
Private Sub talk_Change()
talk.Text = justtext
End Sub
'设置时间的
Private Sub Timer1_Timer()
ws.Close
connect.Enabled = True

Server.Enabled = True
justc = 0
End Sub
'连接服务器 发送自己的地址和名字
Private Sub ws_Connect()
If nam.Text <> "" Then ws.SendData myip.Text + vbNewLine + nam.Text
If nam.Text = "" Then ws.SendData myip.Text + vbNewLine + host.Text  'if no chatname is given, return Computername
Timer1.Enabled = True
justc = 1
End Sub

Private Sub ws_ConnectionRequest(ByVal requestID As Long) '适用于 TCP 服务器应用程序。在请求一个新连接时激活该事件。激活事件之后，RemoteHostIP 和 RemotePort 属性存储有关客户的信息。

Timer1.Enabled = False
ws.Close
ws.LocalPort = 0
ws.Accept requestID
say.Enabled = True
justc = 0
End Sub
'接收到信息存储到dat中
Private Sub ws_DataArrival(ByVal bytesTotal As Long)
ws.GetData dat$
justtext = dat$ + vbNewLine + talk.Text
talk.Text = dat$ + vbNewLine + talk.Text
End Sub

'取本机的hostname
Private Function MyHostName() As String
  Dim HostName As String * 256
  
    If gethostname(HostName, 256) = SOCKET_ERROR Then
      MsgBox "地址错误"
      Exit Function
    Else
      MyHostName = NextChar(Trim$(HostName), Chr$(0))
    End If
End Function

Private Function NextChar(Text$, Char$) As String
  Dim POS%
    POS = InStr(1, Text, Char)
    If POS = 0 Then
      NextChar = Text
      Text = ""
    Else
      NextChar = Left$(Text, POS - 1)
      Text = Mid$(Text, POS + Len(Char))
    End If
End Function

Private Function HostByName(Name$, Optional X% = 0) As String
  Dim MemIp() As Byte
  Dim Y%
  Dim HostDeAddress&, HostIp&
  Dim IpAddress$
  Dim host As HostDeType
  
    HostDeAddress = gethostbyname(Name)
    If HostDeAddress = 0 Then
      HostByName = ""
      Exit Function
    End If
    
    Call RtlMoveMemory(host, HostDeAddress, LenB(host))
    
    For Y = 0 To X
      Call RtlMoveMemory(HostIp, host.hAddrList + 4 * Y, 4)
      If HostIp = 0 Then
        HostByName = ""
        Exit Function
      End If
    Next Y
    
    ReDim MemIp(1 To host.hLength)
    Call RtlMoveMemory(MemIp(1), HostIp, host.hLength)
    
    IpAddress = ""
    
    For Y = 1 To host.hLength
      IpAddress = IpAddress & MemIp(Y) & "."
    Next Y
    
    IpAddress = Left$(IpAddress, Len(IpAddress) - 1)
    HostByName = IpAddress
End Function

'发送完成
Private Sub ws_SendComplete()
If justc = 1 Then
ws.Close
ws.LocalPort = 317
ws.Listen
justc = 0
End If

If justd = 1 Then
ws.Close

connect.Enabled = True

say.Enabled = False
Server.Enabled = True
justd = 0
End If
If justd = 2 Then
ws.Close
End
End If
End Sub