vt100.bas

一个完整的Telnet程序

            yDiff = Val(term_escapeParseArg(EscString))
            If yDiff = 0 Then
                yDiff = 1
            End If

            CurY = CurY + yDiff
            term_validatecurY

        Case "C"
            ' C ==> move cursor right

            EscString = Mid$(EscString, 2)

            xDiff = Val(term_escapeParseArg(EscString))
            If xDiff = 0 Then
                xDiff = 1
            End If

            CurX = CurX + xDiff
            term_validatecurX
        
        Case "D"
            ' D ==> move cursor left

            EscString = Mid$(EscString, 2)

            xDiff = Val(term_escapeParseArg(EscString))
            If xDiff = 0 Then
                xDiff = 1
            End If
            CurX = CurX - xDiff
            term_validatecurX
        
        Case "H"

            'Goto cursor position indicated by escape sequence

            EscString = Mid$(EscString, 2)

            CurY = Val(term_escapeParseArg(EscString)) - 1
            term_validatecurY

            CurX = Val(EscString) - 1
            term_validatecurX

        Case "J"

            'Erase display

            Select Case Val(Mid$(EscString, 2))

                Case 0
                    If CurX = 0 And CurY = 0 Then
                        Call term_eraseSCREEN
                    Else
                        Call term_eraseEOS
                    End If

                Case 1
                    Call term_eraseBOS

                Case 2
                    Call term_eraseSCREEN

            End Select

        Case "K"

            'Erase line
            Select Case Val(Mid$(EscString, 2))
                Case 0
                    'erase to end of line
                    Call term_eraseEOL
                Case 1
                    'erase to end of line
                    Call term_eraseBOL
                Case 2
                    Call term_eraseLINE
            End Select

        Case "f"

            'Goto cursor position indicated by escape sequence

            EscString = Mid$(EscString, 2)

            CurY = Val(term_escapeParseArg(EscString)) - 1
            term_validatecurY

            CurX = Val(EscString) - 1
            term_validatecurX
        
        Case "g"
            ' clear tabs
            
            Dim tY As Integer
            For tY = 0 To 19
              tab_table(tY) = 0
            Next tY
        
        Case "h"

            'restore cursor position
            CurX = SavecurX
            CurY = SavecurY

        Case "i"
            ' print though mode
        
        Case "l"
            'Save cursor position
            SavecurX = CurX
            SavecurY = CurY

        Case "m"

            'Change text attributes, screen colors
            
            EscString = Mid$(EscString, 2)
            Do
                Call term_setattr(Chr$(Val(term_escapeParseArg(EscString))))
            Loop While EscString <> ""

        Case "r"
            
            'Set scrollable region
            EscString = Mid$(EscString, 2)

            lprcScroll.Top = (Val(term_escapeParseArg(EscString)) - 1) * charheight
            lprcClip = lprcScroll
        
        Case "s"
            'Save cursor position
            SavecurX = CurX
            SavecurY = CurY

        Case "u"

            'restore cursor position
            CurX = SavecurX
            CurY = SavecurY


        Case Else

          If frmTelnet.Tracevt100 Then Debug.Print EscString

    End Select

    InEscape = False
    EscString = ""

End Sub

Public Sub term_init()

    'Get the pixel metrics of the current font
    frmTelnet.FontUnderline = False
    frmTelnet.FontItalic = False
    frmTelnet.FontBold = False
    
    frmTelnet.ScaleMode = 3
    charheight = frmTelnet.TextHeight("M")
    charWidth = frmTelnet.TextWidth("M")

    'Set up the vt100 screen
    frmTelnet.ScaleMode = 1
    frmTelnet.Height = (frmTelnet.Height - frmTelnet.ScaleHeight) + LinesPerPage * frmTelnet.TextHeight("M")
    frmTelnet.Height = frmTelnet.Height + frmTelnet.stbStatusBar.Height
    frmTelnet.Width = (frmTelnet.Width - frmTelnet.ScaleWidth) + CharsPerLine * frmTelnet.TextWidth("M")


    'Set the user scale of the display
    frmTelnet.ScaleMode = 0
    frmTelnet.ScaleWidth = LinesPerPage
    frmTelnet.ScaleWidth = CharsPerLine
    frmTelnet.Scale (0, 0)-(LastChar, LastLine)

    'Set up the scoll region and clip region structures
    lprcScroll.Top = 0
    lprcScroll.Left = 0
    lprcScroll.Right = CharsPerLine * charWidth
    lprcScroll.bottom = LinesPerPage * charheight
    lprcClip = lprcScroll
    hRgnUpdate = 0

    'Initialize module level flags and variables
    InEscape = False
    CurState = False
    curattr = "0"
    CurX = 0
    CurY = 0

    'Set the default foreground and background colors
    Ret = SetBkMode(frmTelnet.hdc, OPAQUE)
    frmTelnet.ForeColor = QBColor(15)
    frmTelnet.BackColor = QBColor(0)
    Ret = SetBkColor(frmTelnet.hdc, frmTelnet.BackColor)
    Ret = SetTextColor(frmTelnet.hdc, frmTelnet.ForeColor)

    TermTextColor = GetTextColor(frmTelnet.hdc)
    TermBkColor = GetBkColor(frmTelnet.hdc)


    'Initialize repaint buffer
    Norm_Attr = String$(CharsPerLine, "0")
    Blank_Line = Space$(CharsPerLine)
    term_eraseBUFFER

    FlagInit = True

    'Do the cursor thing
    term_Caretshow
    frmTelnet.cursor_timer.Enabled = True

End Sub
Private Function Term_FindChange(InArray As String, ByVal CurrentValue As String, ByteLen As Integer) As Integer
Dim RetValue As Integer
Dim CurrentByte As Byte
Dim InByte() As Byte

CurrentByte = CurrentValue
InByte = InArray

For RetValue = 1 To ByteLen
    If InByte(RetValue) <> CurrentByte Then
        Exit For
    End If
Next

Term_FindChange = RetValue - 1

End Function
Public Sub term_redrawscreen()

    If Not FlagInit Or frmTelnet.WindowState = 1 Then
        Exit Sub
    End If

    Dim oldcur      As Boolean
    Dim oldattr     As String
    Dim newattr     As String
    Dim Y           As Integer
    Dim X1          As Integer
    Dim X2          As Integer
    Dim AttrChange  As Integer
    Dim tAttr       As String * CharsPerLine
    Dim tLine       As String * CharsPerLine
    
    
    oldcur = CurState
    oldattr = curattr

    If Not frmTelnet.Receiving Then
        Call term_Carethide
    End If

    Call term_setattr("0")

    For Y = 1 To LinesPerPage
        tAttr = ScrAttr(Y)
        tLine = ScrImage(Y)
        If (tAttr = Norm_Attr) Then
            'Normal Lines can be repainted directly
            Ret = TextOut(frmTelnet.hdc, 0, (Y - 1) * charheight, tLine, CharsPerLine)
        Else
            'Complex lines must have attribute changes found using the
            'Term_function FindChange.
            X1 = 1                          'Start the scan on the complete line
            X2 = CharsPerLine
            Do While (X2 > 0)
                AttrChange = Term_FindChange(Mid(tAttr, X1, X2), curattr, X2)
                Ret = TextOut(frmTelnet.hdc, (X1 - 1) * charWidth, (Y - 1) * charheight, Mid$(tLine, X1, AttrChange), AttrChange)
                X2 = X2 - AttrChange
                If X2 > 0 Then
                    X1 = X1 + AttrChange
                    newattr = Mid$(tAttr, X1, 1)
                    If newattr <> "0" Then
                        term_setattr newattr
                    Else
                        curattr = newattr
                    End If
                End If
            Loop
        End If
    Next Y


    Call term_setattr(oldattr)
    If Not frmTelnet.Receiving Then
        If oldcur = True Then
            Call term_Caretshow
        End If
    End If
    

End Sub

Private Sub term_scroll_up()

    Dim I As Integer
    Dim S As Integer

    If frmTelnet.WindowState <> 1 Then
         Ret = ScrollDC(frmTelnet.hdc, 0, -charheight, lprcScroll, lprcClip, hRgnUpdate, lprcUpdate)
         Ret = TextOut(frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine)
    End If

    'Update the redisplay buffer (only update the scrollable region)
    'Might consider making this a circular array so only one line
    'needs to be written per scroll, rather than relinking the array
    S = (lprcScroll.Top \ charheight + 1)
    For I = S To LastLine
        ScrImage(I) = ScrImage(I + 1)
        ScrAttr(I) = ScrAttr(I + 1)
    Next I
    ScrImage(LinesPerPage) = Blank_Line
    ScrAttr(LinesPerPage) = Norm_Attr


End Sub

Private Sub term_setattr(CH As String)
Dim Attr_BitMap As Integer

    Select Case Asc(CH)

            Case 0  '   Normal
               ' Attr_BitMap = Attr_Norm
                
                frmTelnet.FontUnderline = False
                frmTelnet.FontItalic = False
                frmTelnet.FontBold = False
                Ret = SetTextColor(frmTelnet.hdc, TermTextColor)
                Ret = SetBkColor(frmTelnet.hdc, TermBkColor)

            Case 1  '   Bold
               ' Attr_BitMap = Attr_BitMap And Attr_Norm
                frmTelnet.FontBold = True
'                Ret = SetTextColor(frmTelnet.hdc, QBColor(9))

            Case 5  '   Blinking
               ' Attr_BitMap = Attr_BitMap And Attr_Blink
                frmTelnet.FontItalic = True
'                Ret = SetTextColor(frmTelnet.hdc, QBColor(3))

            Case 4  '   Underscore
               ' Attr_BitMap = Attr_BitMap And Attr_Under
                frmTelnet.FontUnderline = True

            Case 7  '   Reverse Video
               ' Attr_BitMap = Attr_BitMap And ATTR_REVERSE
                Ret = SetTextColor(frmTelnet.hdc, TermBkColor)
                Ret = SetBkColor(frmTelnet.hdc, TermTextColor)

            Case 8  '   Cancel (Invisible)
                'Attr_BitMap = Attr_BitMap And ATTR_INVISIBLE
                Ret = SetTextColor(frmTelnet.hdc, TermBkColor)
                Ret = SetBkColor(frmTelnet.hdc, TermBkColor)

            '===============================================================

            Case 30 '   Black Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(0))

            Case 31 '   Red Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(4))

            Case 32 '   Green Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(2))

            Case 33 '   Yellow Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(14))

            Case 34 '   Blue Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(1))

            Case 35 '   Magenta Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(5))

            Case 36 '   Cyan Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(3))

            Case 37 '   White Foreground
                Ret = SetTextColor(frmTelnet.hdc, QBColor(15))

            '===============================================================

            Case 40 '   Black Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(0))

            Case 41 '   Red Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(4))

            Case 42 '   Green Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(2))

            Case 43 '   Yellow Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(14))

            Case 44 '   Blue Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(1))

            Case 45 '   Magenta Background
               Ret = SetBkColor(frmTelnet.hdc, QBColor(5))

            Case 46 '   Cyan Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(3))

            Case 47 '   White Background
                Ret = SetBkColor(frmTelnet.hdc, QBColor(15))

            Case Else
                Exit Sub
    End Select

    curattr = CH
End Sub

Private Sub term_validatecurX()
   If (CurX < 0) Then
        CurX = 0
   ElseIf CurX > LastChar Then
        CurX = LastChar
   End If
End Sub

Private Sub term_validatecurY()
   If (CurY < 0) Then
        CurY = 0
   ElseIf CurY > LastLine Then
        CurY = LastLine
   End If
End Sub

Private Sub term_write(CH As Byte)

    If frmTelnet.WindowState <> 1 Then
        Ret = TextOut(frmTelnet.hdc, CurX * charWidth, CurY * charheight, Chr$(CH), 1)
    End If

    If Not (CurX = LastChar) Then
        CurX = CurX + 1
    End If

End Sub