frmchatclnt.frm

vb代码集,收集许多VB网络编程代码

VERSION 5.00
Begin VB.Form frmChat 
   Caption         =   "Chat Client"
   ClientHeight    =   4890
   ClientLeft      =   1905
   ClientTop       =   2595
   ClientWidth     =   8400
   LinkTopic       =   "Form1"
   PaletteMode     =   1  'UseZOrder
   ScaleHeight     =   4890
   ScaleWidth      =   8400
   Begin VB.TextBox Host 
      Height          =   285
      Left            =   1440
      TabIndex        =   9
      Text            =   "ChatSvr"
      Top             =   240
      Width           =   2415
   End
   Begin VB.TextBox txtUserName 
      Height          =   285
      Left            =   1440
      TabIndex        =   8
      Text            =   "UserName"
      Top             =   600
      Width           =   2415
   End
   Begin VB.TextBox txtPort 
      Height          =   285
      Left            =   5520
      TabIndex        =   7
      Text            =   "2000"
      Top             =   240
      Width           =   2655
   End
   Begin VB.TextBox txtThisHost 
      Height          =   285
      Left            =   5520
      TabIndex        =   6
      Text            =   "This Host Name"
      Top             =   600
      Width           =   2655
   End
   Begin VB.Timer Timer1 
      Left            =   3600
      Top             =   1440
   End
   Begin VB.CommandButton cmdSend 
      Caption         =   "Send Text"
      Height          =   615
      Left            =   6960
      TabIndex        =   5
      Top             =   4080
      Width           =   1215
   End
   Begin VB.TextBox txtSend 
      Height          =   1575
      Left            =   120
      TabIndex        =   4
      Top             =   3120
      Width           =   6495
   End
   Begin VB.CommandButton cmdExit 
      Caption         =   "Exit"
      Height          =   615
      Left            =   6960
      TabIndex        =   3
      Top             =   2760
      Width           =   1215
   End
   Begin VB.CommandButton DoFinger 
      Caption         =   "Connect"
      Height          =   615
      Left            =   6960
      TabIndex        =   1
      Top             =   1320
      Width           =   1215
   End
   Begin VB.TextBox HostResponse 
      BeginProperty Font 
         Name            =   "Courier New"
         Size            =   8.25
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   1575
      Left            =   120
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   0
      Top             =   1320
      Width           =   6495
   End
   Begin VB.Label lblUserName 
      Caption         =   "User Name;"
      Height          =   255
      Left            =   120
      TabIndex        =   13
      Top             =   600
      Width           =   1215
   End
   Begin VB.Label lblPort 
      Caption         =   "Port:"
      Height          =   255
      Left            =   4320
      TabIndex        =   12
      Top             =   240
      Width           =   975
   End
   Begin VB.Label Label5 
      Caption         =   "This Host:"
      Height          =   255
      Left            =   4320
      TabIndex        =   11
      Top             =   600
      Width           =   1095
   End
   Begin VB.Label Label6 
      Caption         =   "Server:"
      Height          =   255
      Left            =   120
      TabIndex        =   10
      Top             =   240
      Width           =   855
   End
   Begin VB.Label Label1 
      Caption         =   "Communication:"
      Height          =   255
      Left            =   120
      TabIndex        =   2
      Top             =   1080
      Width           =   1335
   End
End
Attribute VB_Name = "frmChat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim formHeightDiff As Integer
Dim formWidthDiff As Integer
Dim StartupData As WSADataType
Dim Sock As Integer
Dim SocketBuffer As sockaddr




Public Function VBgethostname() As String
    Dim tempstr As String
    Dim strlen As Integer, retval As Integer
        Dim StartupData As WSADataType

    retval = WSAStartup(&H101, StartupData)
    If retval = SOCKET_ERROR Then Exit Function
    
    strlen = 128
    tempstr = Space$(strlen)
    retval = 0
    retval = gethostname(tempstr, strlen)
    If retval = 0 Then
        VBgethostname = Left(Trim$(tempstr), (InStr(Trim$(tempstr), Chr(0)) - 1))
    Else
        VBgethostname = "get_hostname: ERROR"
    End If
    tempstr = ""
    
End Function


Public Function VBgetusername() As String
    Dim tempstr As String
    Dim strlen As Integer, retval As Integer
    Dim lname As Long
    strlen = 128
    tempstr = Space$(strlen)
    retval = WNetGetUser(lname, tempstr, 128)
    If retval = 0 Then
        VBgetusername = Trim$(tempstr)
    Else
        VBgetusername = "getusername: ERROR"
    End If
    tempstr = ""
End Function


Private Sub cmdExit_Click()
    closesocket Sock
    End

End Sub

Private Sub cmdSend_Click()
    Dim RC As Integer
    Dim IPAddr As Long
    Dim MsgBuffer As String * 2048
    Dim Regel As String
    Dim Bytes As Integer
    Dim Character As String '
    Dim FromAddr As String
    Dim FromName As String
    Dim ToAddr As String
    Dim ToName As String
    Dim SelectOps As Long

    Regel = txtSend & Chr(13) & Chr(10) '
    HostResponse.Text = HostResponse.Text + Regel
    RC = send(Sock, ByVal Regel, Len(Regel), 0)
    If RC = SOCKET_ERROR Then
        HostResponse.Text = "Cannot Send Request." + _
                            Chr$(13) + Chr$(10) + _
                            Str$(WSAGetLastError()) + _
                            GetWSAErrorString(WSAGetLastError())
        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If
    

End Sub


Private Sub Form_Load()
    'formHeightDiff = Finger.Height - HostResponse.Height
    'formWidthDiff = Finger.Width - HostResponse.Width

    Me.txtUserName = VBgetusername()
    Me.txtThisHost = VBgethostname

End Sub

Private Sub Form_Resize()
    'HostResponse.Height = Finger.Height - formHeightDiff
    'HostResponse.Width = Finger.Width - formWidthDiff
End Sub

Private Sub DoFinger_Click()
    Dim RC As Integer
    Dim IPAddr As Long
    Dim MsgBuffer As String * 2048
    Dim Regel As String
    Dim Bytes As Integer
    Dim Character As String
    Dim FromAddr As String
    Dim FromName As String
    Dim ToAddr As String
    Dim ToName As String
    Dim SelectOps As Long

    HostResponse.Text = "Starting:" & Chr$(13) + Chr$(10)
    RC = WSAStartup(&H101, StartupData)
    If RC = SOCKET_ERROR Then Exit Sub

    IPAddr = GetHostByNameAlias(Host)
    If IPAddr = -1 Then
        HostResponse.Text = "Unknown Host: " + Host
        Exit Sub
    End If

    Sock = socket(AF_INET, SOCK_STREAM, 0)
    If Sock = SOCKET_ERROR Then
        HostResponse.Text = "Cannot Create Socket."
        Exit Sub
    End If

    SocketBuffer.sin_family = AF_INET
    SocketBuffer.sin_port = htons(4000) 'GetServiceByName("smtp", "TCP")
    SocketBuffer.sin_addr = IPAddr
    SocketBuffer.sin_zero = String$(8, 0)
        '   String: Returns a repeating character string of the length specified.
        
    SelectOps = FD_READ Or FD_WRITE Or FD_CLOSE Or FD_CONNECT
    RC = connect(Sock, SocketBuffer, Len(SocketBuffer)) ' Blocking Connection Request
    DoEvents
    
    If RC = SOCKET_ERROR Then
        HostResponse.Text = "Cannot Connect to ... Server." + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())

        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If
    DoEvents
    RC = ioctlsocket(Sock, FIONBIO, True)  ' Set Socket to non blocking if connection successful
    If RC = SOCKET_ERROR Then
        HostResponse.Text = "Cannot unblock socket... " + _
                            Chr$(13) + Chr$(10) + _
                            GetWSAErrorString(WSAGetLastError())

        closesocket Sock
        RC = WSACleanup()
        Exit Sub
    End If
    Timer1.Interval = 50
    DoEvents
    DoFinger.Enabled = False

End Sub



Public Function ReadLineFromSocket(Sock As Integer)
    Dim Tekens As String * 100
    Dim Aantal As Integer
    Dim Character As String * 1
    Dim Result As String
    Dim Result2 As String
    ' Carriage return (vbCr = Chr$(13))
    ' Linefeed (vbLf = Chr$(10))
       
    DoEvents
    Do
        DoEvents
        Aantal = recv(Sock, ByVal Tekens, 1, 0)  ' Non-Blocking!
        
        If (Aantal > 0) Then
            Character = Left$(Tekens, Aantal)
            If (Asc(Character) >= Asc(" ")) Then
                Result = Result & Character
            End If
        Else
            Result = ""
            Exit Do
        End If
        If Character = "" Then
            Character = Chr(13)
        End If
    Loop While ((Aantal > 0) And (Asc(Character) <> 13))
    ReadLineFromSocket = Result
End Function

Private Sub Timer1_Timer()
    Dim Regel As String

    Regel = ReadLineFromSocket(Sock)
    If Len(Regel) > 0 Then
        HostResponse.Text = HostResponse.Text & "<<< " & Regel & vbCrLf
    End If
    DoEvents
End Sub