株式会社ウィル

'CHATSRV 1.1 (C)COPYRIGHT 1997 WILL
Option Explicit
'List1にログメッセージを追加する
Private Sub addlog(msg$)
    List1.AddItem msg                   'メッセージを追加する
    List1.ListIndex = List1.NewIndex    '追加した行をハイライトにする
    If (List1.ListCount > 100) Then     '100行を超えるときは
        List1.RemoveItem 0              '先頭から削除してゆく
    End If
End Sub
'開始ボタン
Private Sub Command1_Click()
    Command1.Enabled = False            '開始ボタンを押せないようにする
    Command2.Enabled = True             '中断ボタンは有効
    Tcpip1.Listen "2000"                'ポート2000で接続を待つ
    addlog "START"                      'ログに開始したことを記録する
End Sub
'中断ボタン  
Private Sub Command2_Click()
    Tcpip1.Close                        '待ちポートを閉じる。Closedイベントがあがる
End Sub
'終了ボタン
Private Sub Command3_Click()
    Dim tcp As Object   '接続中のオブジェクト
    
    Tcpip1.Close                        'まず待ちポートを閉じる
    For Each tcp In Tcpip2              '接続中のオブジェクトを取り出し
        tcp.Close                       '接続を閉じてから
    Next
    End                                 '終了する
End Sub
'著作権表示
Private Sub Form_Load()
    Label2 = Tcpip1.copyright           '使用しているTCPIPOCXの著作権を表示する
End Sub
'フォームの大きさに応じてログエリアの大きさを調整する
Private Sub Form_Resize()
    Dim w%, h%      'ログエリアの幅と高さ
    
    List1.Left = 0                      '左端にピタットつける
    w = Me.ScaleWidth                   '幅はフォームの幅と同じ
    h = Me.ScaleHeight - List1.Top      '高さを調節してフォームの下弦にピタットつける
    If (w > 0 And h > 0) Then           '表示できない大きさでない限り
        List1.Width = w                 '幅と
        List1.Height = h                '高さを変更する
    End If
End Sub
'接続要求が来た
Private Sub Tcpip1_Accepting(ByVal NewSocket As Long, ByVal RemoteIp As Long,
ByVal RemotePort As Integer, CancelAccept As Boolean)
    Load Tcpip2(NewSocket)              '通信のためのソケットオブジェクトを用意して
    Tcpip2(NewSocket).Accept NewSocket  '新たに接続を開始する
    Tcpip3.InetIp = RemoteIp            '相手のアドレスをドット表記して
    Tcpip3.StopRequest                  '検索する必要はない
    Tcpip2(NewSocket).UserData1 = Tcpip3.InetAddress & ":" & RemotePort '記憶する
    addlog "ENTER " & NewSocket & ":" & Tcpip3.InetAddress & ":" & RemotePort
End Sub
'接続が切れた。新たな接続はない
Private Sub Tcpip1_Closed()
    Command1.Enabled = True
    Command2.Enabled = False
    addlog "STOP"
End Sub
'通信エラーが発生した
Private Sub Tcpip1_WsError(ByVal Ecode As Long, ByVal Description As String,
ByVal Where As String, CancelClose As Boolean)
    MsgBox Description & "(" & Ecode & ")", vbExclamation, "Tcpip1_WsError"
End Sub

'個々の通信が切れた
Private Sub Tcpip2_Closed(Index As Integer)
    Unload Tcpip2(Index)                'オブジェクトをメモリから削除する
    addlog "LEAVE " & Index
End Sub
'Acceptメソッドの結果接続した
Private Sub Tcpip2_Connected(Index As Integer)
    Tcpip2(Index).Tag = ""          '送信待ちのデータ
    Tcpip2(Index).UserData2 = ""    'ユーザーの名前
End Sub
'データを受信した
Private Sub Tcpip2_Received(Index As Integer, data As String)
    Dim x$, w$, tcp As Object
    
    x = StrConv(data, vbUnicode)        'ANSI/DBCSからUnicodeに変換
    Tcpip2(Index).UserData2 = x         '送信者の名前を記憶する
    addlog "RECV  " & Index & ":" & x
    If (InStr(x, "#who#") > 0) Then     '接続中のユーザーリストを要求しているので
        w = "接続中のユーザーリスト" & vbCrLf
        For Each tcp In Tcpip2          '接続中のオブジェクトを取り出し
            If (tcp.Index <> 0) Then    'ダミーを無視する
                w = w & "[" & tcp.UserData1 & "]" & tcp.UserData2
            End If
        Next
        w = StrConv(w, vbFromUnicode)   'UnicodeをANSI/DBCSに変換して
        If (Tcpip2(Index).Sendable = True) Then '送信可能なら
            Tcpip2(Index).Send w        'そのまま送り
        Else                            '無理なら
            Tcpip2(Index).Tag = Tcpip2(Index).Tag & w   '保留して送信可能になったら
        End If                                          '(Sentイベント)で送信する
    Else                                '受信したデータを全員にブロードキャストする
        For Each tcp In Tcpip2          '接続中のオブジェクトを取り出し、
            If (tcp.Index <> 0) Then    'ダミーを無視する
                If (tcp.Sendable = True) Then   '送信可能なら
                    tcp.Send data       'そのまま送り
                Else                    '無理なら
                    tcp.Tag = tcp.Tag & data    '保留して送信可能になったら
                End If                          '(Sentイベント)で送信する
            End If
        Next
    End If
End Sub
'送信可能になった
Private Sub Tcpip2_Sent(Index As Integer)
    Dim x$
    
    If (Tcpip2(Index).Tag <> "") Then   '保留されているデータがあるなら
        x = Tcpip2(Index).Tag           '文字列変数に移して
        Tcpip2(Index).Tag = ""          '保留を解除したうえで
        Tcpip2(Index).Send x            '送信する
    End If
End Sub
'通信エラーが発生した
Private Sub Tcpip2_WsError(Index As Integer, ByVal Ecode As Long, ByVal Description As String,
ByVal Where As String, CancelClose As Boolean)
    MsgBox Description & "(" & Ecode & ")", vbExclamation, "Tcpip2_WsError"
End Sub

'CHATCLT 1.1(C)COPYRIGHT 1997 WILL Option Explicit 'データを送信する Private Sub send(ByVal msg$) Dim x$ 'ANSI/DBCS文字列を保持する '送信するデータをUnicodeからANSI/DBCSに変換する x = StrConv(Text1 & ":" & msg & vbCrLf, vbFromUnicode) If (Tcpip1.Sendable = True) Then '送信可能であるならば、 Tcpip1.send x '送信する Else '不可能なら、 Tcpip1.Tag = Tcpip1.Tag & x '可能になるのを待つ(sentイベント) End If End Sub '接続ボタン Private Sub Command1_Click() If (Text1 = "") Then '名前が入っていない MsgBox "名前を入れてください", vbExclamation, "Command1_Click" Exit Sub End If If (Text4 = "") Then 'サーバーのアドレスが入っていない MsgBox "サーバーアドレスを入れてください", vbExclamation, "Command1_Click" Exit Sub End If Text1.Enabled = False '接続したら名前は変更できない Command1.Enabled = False '接続中は接続できない Command2.Enabled = True '中断ボタンを有効にする Tcpip1.Connect Text4, "2000", "0" End Sub '中断ボタン Private Sub Command2_Click() Tcpip1.UserFlag = "1" '最後の送信が完了したらCloseせよ send "BYE" 'さよなら End Sub '送信ボタン Private Sub Command3_Click() send Text2 'メッセージを送信する Text2.SetFocus 'Text2にフォーカスを移動します Text2.SelStart = 0 '送信したメッセージを Text2.SelLength = Len(Text2) 'ハイライトにする End Sub 'フォームがロードされた Private Sub Form_Load() Label2 = Tcpip1.copyright '使用しているTCPIPOCXの著作権表示 End Sub 'フォームの大きさが変わった Private Sub Form_Resize() Dim w%, h% '受信データ表示エリアの大きさ Text3.Left = 0 'フォームの左端にぴったりつける w = Me.ScaleWidth 'フォームの幅と同じ h = Me.ScaleHeight - Text3.Top 'フォームの下弦にぴったりとつける If (w > 0 And h > 0) Then '表示不可能な大きさでない限り Text3.Width = w '幅と Text3.Height = h '高さを変更する End If End Sub '通信が切断された Private Sub Tcpip1_Closed() Text1.Enabled = True Text2.Enabled = False Command1.Enabled = True Command2.Enabled = False Command3.Enabled = False Command1.Default = True 'エンターキーがおされたら接続開始 End Sub '接続した Private Sub Tcpip1_Connected() Tcpip1.Tag = "" '送信待ちのデータ Tcpip1.UserFlag = "" '送信後にクローズするためのフラグ send "HELLO" 'みなさんに接続した挨拶をする 'メッセージ送信可能 Text2.Enabled = True Command3.Enabled = True Command3.Default = True 'エンターキーで送信する End Sub 'データを受信した Private Sub Tcpip1_Received(data As String) Text3.SelStart = Len(Text3) 'テキストボックスの最後に Text3.SelText = StrConv(data, vbUnicode) 'Unicodeに変換して追加する End Sub 'データの送信完了。次のデータを送信可能になった Private Sub Tcpip1_Sent() Dim x$ 'Sendメソッドは文字変数をパラメータにしなくてはならない If (Tcpip1.Tag <> "") Then '送信が保留されているデータがあるなら x = Tcpip1.Tag 'それを文字列変数にいれ Tcpip1.Tag = "" '保留状態を解除したうえで Tcpip1.send x '送信する ElseIf (Tcpip1.UserFlag = "1") Then '送信後にクローズせよという指示があるなら Tcpip1.UserFlag = "" 'フラグを解除した上で、 Tcpip1.Close '接続を閉じる End If End Sub '通信エラーが発生した。その後Closedイベントがあがる Private Sub Tcpip1_WsError(ByVal Ecode As Long, ByVal Description As String, ByVal Where As String, CancelClose As Boolean) MsgBox Description & "(" & Ecode & ")", vbExclamation, "Tcpip1_WsError" End Sub

チャットサーバー

■使い方

ソースコード

チャットクライアント

■使い方

ソースコード