WILLはネットワークに関するあらゆるソリューションをご提供します。
	株式会社ウィル

使い方

リモート コンピュータに接続するには [FILE] メニューの [CONNECT] をクリックします。 [サーバー] ボックスに、接続するリモート システムのIPアドレスを入力します。 [ポート] ボックスで、使用するポート番号を指定します。 端末の種類を指定するには、[ターミナルタイプ] ボックスで、使用する文字列を入力する。 (ディフォルトは"dumb"となっています。） [CONNECT]ボタンをクリックします。 送信文字コードの指定 [EDIT] メニューの [SEND CODE] を選択します。 指定する文字コードをクリックします。 受信文字コードの指定 [EDIT] メニューの [RECV CODE] を選択します。 指定する文字コードをクリックします。

デザインタイム画面

ソースコード

Option Explicit

Private SendData$
Private tWILL$, tWONT$, tDO$, tDONT$, tIAC$, tIP$, tDM$
Private tSB$, tSE$, toTYPE$, toECHO$, toSGA$
Private SendCode$

Private Sub Command1_Click()
    Tcpip1.Connect Text3, Text4, "0"
    Frame1.Visible = False
    m_connect.Enabled = False
    m_disconnect.Enabled = True
End Sub

Private Sub Command3_Click()
    m_connect.Enabled = True
    m_disconnect.Enabled = False
    Frame1.Visible = False
End Sub

Private Sub Form_Load()
    tWILL = ChrB$(251)
    tWONT = ChrB$(252)
    tDO = ChrB$(253)
    tDONT = ChrB$(254)
    tIAC = ChrB$(255)
    tSB = ChrB$(250)
    tSE = ChrB$(240)
    tIP = ChrB$(244)
    tDM = ChrB$(242)
    toTYPE = ChrB$(24)
    toECHO = ChrB$(1)
    toSGA = ChrB$(3)
    SendCode = "SJIS"
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Tcpip1.Close
End Sub

Private Sub Form_Resize()
    If (Me.WindowState <> 1) Then
        Text1.Top = 0
        Text1.Left = 0
        Text1.Width = Me.ScaleWidth
        Text1.Height = Me.ScaleHeight
    End If
End Sub

Private Sub m_connect_Click()
    Frame1.Visible = True
    Text3.SetFocus
End Sub

Private Sub m_disconnect_Click()
    Tcpip1.Close
    m_connect.Enabled = True
    m_disconnect.Enabled = False
End Sub

Private Sub m_quit_Click()
    Unload Me
End Sub

Private Sub m_recvcode_Click(Index As Integer)
    m_recvcode(0).Checked = False
    m_recvcode(1).Checked = False
    m_recvcode(Index).Checked = True
    Kanji1.DefaultEncoding = m_recvcode(Index).Caption
End Sub

Private Sub m_sendcode_Click(Index As Integer)
    SendCode = m_sendcode(Index).Caption
    m_sendcode(0).Checked = False
    m_sendcode(1).Checked = False
    m_sendcode(2).Checked = False
    m_sendcode(Index).Checked = True
End Sub

Private Sub Tcpip1_Closed()
    MsgBox "接続がきれました。", vbInformation, "DISCONNECTED"
    m_connect.Enabled = True
    m_disconnect.Enabled = False
End Sub
Private Function Response(c2$, c3$, f As Boolean)
    Dim s$, s1$, s2$
    If (f = True) Then
        s1 = tDO
        s2 = tWILL
    Else
        s1 = tDONT
        s2 = tWONT
    End If
    Select Case c2
    Case tWILL
        s = tIAC & s1 & c3
    Case tDO
        s = tIAC & s2 & c3
    Case tWONT
        s = tIAC & tDONT & c3
    Case tDONT
        s = tIAC & tWONT & c3
    Case Else
        MsgBox "オプション交渉コマンドでない" & AscB(c3)
        Exit Function
    End Select
    Response = s
End Function

Private Sub Tcpip1_Connected()
    Text1 = ""
End Sub

Private Sub Tcpip1_Received(data As String)
    Static remain$, kanji$
    Dim c1$, c2$, c3$, c4$, c5, s$, t$, q$, p1%, p2%, p3%, p0%, str$
    Dim i%
    'dumpx data
    
    remain = remain & data
    Do While (LenB(remain) > 0)
        c1 = LeftB$(remain, 1)
        Select Case c1
        Case tIAC
            If (LenB(remain) < 3) Then
                Exit Do
            End If
            c1 = MidB$(remain, 1, 1)
            c2 = MidB$(remain, 2, 1)
            c3 = MidB$(remain, 3, 1)
            If (c2 = tSB) Then
                If (InStrB(remain, tIAC & tSE) = 0) Then
                    Exit Do
                End If
                c4 = MidB$(remain, 4, 1)
                c5 = MidB$(remain, 5)
                remain = MidB$(remain, InStrB(remain, tIAC & tSE) + 2)
            Else
                remain = MidB$(remain, 4)
            End If
            Select Case c2
            Case tWILL
                Select Case c3
                Case toECHO 'echo
                    s = Response(c2, c3, True)
                Case toSGA 'supress go ahead
                    s = Response(c2, c3, True)
                Case Else
                    s = Response(c2, c3, False)
                End Select
            Case tDO
                Select Case c3
                Case toECHO 'echo
                    s = Response(c2, c3, True)
                Case toSGA 'supress go ahead
                    s = Response(c2, c3, True)
                Case toTYPE ' Terminal Type
                    s = Response(c2, c3, True)
                Case Else
                    s = Response(c2, c3, False)
                End Select
            Case tSB
                Select Case c3
                Case toTYPE ' Terminal Type
                    Select Case AscB(c4)
                    Case 0 'IS
                    Case 1 'SEND
                        s = tIAC & tSB & toTYPE & ChrB$(0) & StrConv(Text2, vbFromUnicode) & tIAC & tSE
                    End Select
                End Select
            Case tWONT
                s = tIAC & tWONT & c3
            Case tDONT
                s = tIAC & tWONT & c3
            Case tIAC
            Case tDM
            Case Else
                MsgBox "しらないTELNETコマンドがきてしまった。" & AscB(c2)
                Exit Sub
            End Select
            SendData = SendData & s
            If (Tcpip1.Sendable = True) Then
                s = SendData
                SendData = ""
                Tcpip1.Send s
            End If
        Case ChrB$(0)
            Text1.SelStart = Len(Text1)
            Text1.SelText = StrConv(ChrB$(10), vbUnicode)
            remain = MidB$(remain, 2)
        Case ChrB$(7)
            remain = MidB$(remain, 2)
        Case ChrB$(8) 'Back Space
            Text1.SelStart = Len(Text1) - 1
            Text1.SelLength = 1
            Text1.SelText = ""
            remain = MidB$(remain, 2)
        Case Else
            p1 = InStrB(remain, tIAC)
            p2 = InStrB(remain, ChrB$(0))
            p3 = InStrB(remain, ChrB$(8))
            p0 = LenB(remain) + 1
            If (p1 > 0 And p0 > p1) Then p0 = p1
            If (p2 > 0 And p0 > p2) Then p0 = p2
            If (p3 > 0 And p0 > p3) Then p0 = p3
            str = LeftB$(remain, p0 - 1)
            remain = MidB$(remain, p0)
            kanji = kanji & str
            q = kanji
            t = Kanji1.Any2Sjis(kanji)
            If (LenB(t) = 1 And Kanji1.LastEncoding <> "ASCII") Then
                kanji = q
                t = ""
            ElseIf (LeftB$(t, 1) = ChrB$(&H1B) And LenB(t) < 3) Then
                kanji = q
                t = ""
            End If
            If (LenB(t) > 0) Then
                On Error GoTo text_full_error
                Text1.SelStart = Len(Text1)
                Text1.SelText = StrConv(t, vbUnicode)
            End If
        End Select
    Loop
    Exit Sub

text_full_error:
    MsgBox "テキストボックスが溢れました。削除して継続します。", vbCritical, "TEXT AREA FULL"
    Text1 = ""
    Text1.SelStart = Len(Text1)
    Resume
End Sub

Private Sub Tcpip1_Sent()
    Dim s$
    If (LenB(SendData) > 0) Then
        s = SendData
        SendData = ""
        Tcpip1.Send s
    End If
End Sub

Private Sub Text1_KeyPress(KeyAscii As Integer)
    Dim s$, c1%, c2%, k&, t$
    
    k = KeyAscii
    If (k < 0) Then k = 65536 + k
    If (k = 13) Then
        s = ChrB$(13) & ChrB$(10)
    ElseIf (k = 3) Then
        s = tIAC & tIP
    ElseIf (k < 256) Then
        s = ChrB$(k)
    Else
        t = Tcpip1.htons(KeyAscii)
        Select Case SendCode
        Case "SJIS"
            s = t
        Case "JIS"
            s = Kanji1.Sjis2Jis(t)
        Case "EUC"
            s = Kanji1.Sjis2Euc(t)
        End Select
    End If
    KeyAscii = 0
    s = SendData & s
    If (Tcpip1.Sendable = True) Then
        SendData = ""
        Tcpip1.Send s
    Else
        SendData = s
    End If
    
End Sub