vt100.bas

一个完整的Telnet程序

Attribute VB_Name = "vt100"
Option Explicit

'Windows RECT structure
Private Type RECT
    Left    As Long
    Top     As Long
    Right   As Long
    bottom  As Long
End Type


Private Declare Function ScrollWindow Lib "user32" (ByVal hWnd As Long, ByVal XAmount As Long, ByVal YAmount As Long, lpRect As RECT, lpClipRect As RECT) As Long
Private Declare Function ScrollDC Lib "user32" (ByVal hdc As Long, ByVal dx As Long, ByVal dy As Long, lprcScroll As RECT, lprcClip As RECT, ByVal hRgnUpdate As Long, lprcUpdate As RECT) As Long
Private Declare Function PatBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nwidth As Long, ByVal nheight As Long, ByVal dwRop As Long) As Long
Private Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetBkMode Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function PaintRgn Lib "gdi32" (ByVal hdc As Long, ByVal hRgn As Long) As Long

Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal newcolor As Long) As Long
Private Declare Function IsCharAlpha Lib "user32" Alias "IsCharAlphaA" (ByVal cChar As Byte) As Long


'=================== Ternary raster operations ============
Private Const PATCOPY = &HF00021         ' (DWORD) dest = pattern
Private Const PATPAINT = &HFB0A09        ' (DWORD) dest = DPSnoo
Private Const PATINVERT = &H5A0049       ' (DWORD) dest = pattern XOR dest
Private Const DSTINVERT = &H550009       ' (DWORD) dest = (NOT dest)
Private Const BLACKNESS = &H42&          ' (DWORD) dest = BLACK
Private Const WHITENESS = &HFF0062       ' (DWORD) dest = WHITE
Private Const TRANSPARENT = 1
Private Const OPAQUE = 2
Private Const GO_IAC1 = 6



Private Const LinesPerPage = 25
Private Const CharsPerLine = 80
Private Const TabsPerPage = 20

Private Const LastLine = LinesPerPage - 1
Private Const LastChar = CharsPerLine - 1
Private Const LastTab = 19

Private ScrImage(LinesPerPage)    As String * CharsPerLine
Private ScrAttr(LinesPerPage)     As String * CharsPerLine
Private Norm_Attr                 As String * CharsPerLine
Private Blank_Line                As String * CharsPerLine

Private TermTextColor             As Long
Private TermBkColor               As Long

Private tabno                     As Integer
Private tab_table(TabsPerPage)    As Integer
Private curattr                   As String

Private lprcScroll                As RECT
Private lprcClip                  As RECT
Private hRgnUpdate                As Integer
Private lprcUpdate                As RECT


'
'   Current Buffered Text waiting for output on screen
'

Private OutStr          As String
Private outlen          As Integer

'
'   Flag to indicate that we're ready to run
'
Private FlagInit        As Integer

Private CurX            As Integer
Private CurY            As Integer
Private SavecurX        As Integer
Private SavecurY        As Integer

Private InEscape        As Boolean    ' Processing an escape seq?
Private EscString       As String     ' String so far

Private charheight      As Single
Private charWidth       As Single

Private CurState        As Boolean
Private Ret             As Long



Public Function term_process_char(CH As Byte)

       
    If (InEscape) Then
        
        Call term_escapeProcess(CH)
    
    Else
        
        Select Case CH

        Case 0

        Case 7

            Beep

        Case 8


            If CurX > 0 Then                    '   if not at line begin
                CurX = CurX - 1                 '   adjust back 1 spc
            End If

        Case 9
            Dim tY As Integer
            For tY = 0 To 19
              If CurY < tab_table(tY) Then
                Exit For
              End If
            Next tY
            CurY = tab_table(tY)

        Case 10, 11, 12

            If (CurY = LastLine) Then           '   if line left on scrn
                Call term_scroll_up             '   ..  scroll upwards
                CurY = LastLine                 '   ..  use blank line
            Else
                CurY = CurY + 1                 '   goto next line
            End If

        Case 13
        
            CurX = 0
            
        Case 27

            InEscape = True
            EscString = ""

        Case 255
            
            term_process_char = GO_IAC1
        
        Case Else
            
          ' if (CH > 31) Then ' And (CH < 128)
                term_write CH
                Mid$(ScrImage(CurY + 1), CurX, 1) = Chr$(CH)
                Mid$(ScrAttr(CurY + 1), CurX, 1) = curattr
           ' End If

        End Select
        
    End If
End Function
Public Sub term_CaretControl(TurnOff As Boolean)
Static SaveState As Boolean

    If TurnOff = True Then
        SaveState = CurState
        term_Carethide
    Else
        If SaveState = True Then
            term_Caretshow
        End If
    End If
    
End Sub
Private Sub term_Carethide()

    If CurState = True Then
        If frmTelnet.WindowState <> 1 Then
            Ret = PatBlt(frmTelnet.hdc, CurX * charWidth, CurY * charheight, charWidth, charheight, DSTINVERT)
        End If
        CurState = False
    End If
End Sub

Private Sub term_Caretshow()

    '------------------------------------------------------------------------
    '   term_CaretShow
    '
    '   display the inverted block cursor on the screen.
    '   currently uses PatBlt.
    '------------------------------------------------------------------------
    Dim Ret As Integer

    If frmTelnet.WindowState <> 1 Then
       Ret = PatBlt(frmTelnet.hdc, CurX * charWidth, CurY * charheight, charWidth, charheight, DSTINVERT)
    End If

    CurState = True

End Sub
Public Sub term_DriveCursor()
    If CurState = False Then
        Call term_Caretshow
    Else
        Call term_Carethide
    End If
End Sub
Private Sub term_eraseBOL()
'------------------------------------------------------------------------
'   term_eraseBOL
'   erase from beginning of current line
'------------------------------------------------------------------------
    Dim Ret As Integer

    If frmTelnet.WindowState <> 1 Then
       ' Ret = PatBlt(frmTelnet.hdc, 0, CurY * charheight, curX * charWidth, charheight, BLACKNESS)
        Ret = TextOut(frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine)
        
    End If

    Mid$(ScrImage(CurY + 1), 1, CurX + 1) = Space$(CurX + 1)
    Mid$(ScrAttr(CurY + 1), 1, CurX + 1) = String$(CurX + 1, "0")
End Sub

Private Sub term_eraseBOS()
'------------------------------------------------------------------------
'   term_eraseBOS
'   erase all lines from beginning of screen to and including current
'------------------------------------------------------------------------
    Dim Y As Integer

    'Erase the current line first
    Call term_eraseBOL

    'Erase everything up to current line
    If (CurY > 0) Then
        If frmTelnet.WindowState <> 1 Then
            Ret = TextOut(frmTelnet.hdc, 0, 0, Space$(CharsPerLine * CurY + CurX), CharsPerLine * CurY + CurX)
            
        End If

        ' reset screen buffer contents
        For Y = 1 To CurY
           ScrImage(Y) = Blank_Line
           ScrAttr(Y) = Norm_Attr
        Next Y
    End If
End Sub

Private Sub term_eraseBUFFER()
    Dim I As Integer
    For I = 1 To LinesPerPage
        ScrImage(I) = Blank_Line
        ScrAttr(I) = Norm_Attr
    Next I
End Sub

Private Sub term_eraseEOL()
'
'   Erase to End of Line
'
    If frmTelnet.WindowState <> 1 Then
        Ret = TextOut(frmTelnet.hdc, CurX * charWidth, CurY * charheight, Space$(CharsPerLine - CurX), CharsPerLine - CurX)
    End If

    'Update screen buffer
    Mid$(ScrImage(CurY + 1), CurX + 1, CharsPerLine - CurX) = Space$(CharsPerLine - CurX)
    Mid$(ScrAttr(CurY + 1), CurX + 1, CharsPerLine - CurX) = String$(CharsPerLine - CurX, "0")

End Sub

Private Sub term_eraseEOS()
'
'   Erase to end of screen
'
    Dim Y As Integer

    Call term_eraseEOL
    If (CurY <> LastLine) Then

        If frmTelnet.WindowState <> 1 Then
            Ret = TextOut(frmTelnet.hdc, 0, (CurY + 1) * charheight, Space$((LastLine - CurY) * CharsPerLine), (LastLine - CurY) * CharsPerLine)
        End If

        For Y = CurY + 2 To LinesPerPage
            ScrImage(Y) = Blank_Line
            ScrAttr(Y) = Norm_Attr
        Next Y

     End If
End Sub

Private Sub term_eraseLINE()

'   Erase Line

    If frmTelnet.WindowState <> 1 Then
        Ret = TextOut(frmTelnet.hdc, 0, CurY * charheight, Blank_Line, CharsPerLine)
    End If

    ScrImage(CurY + 1) = Blank_Line
    ScrAttr(CurY + 1) = Norm_Attr

End Sub

Private Sub term_eraseSCREEN()

    'Assume that they want to repaint using the latest background color
    
    TermBkColor = GetBkColor(frmTelnet.hdc)
    TermTextColor = GetTextColor(frmTelnet.hdc)
    
    frmTelnet.BackColor = TermBkColor
    frmTelnet.ForeColor = TermTextColor

    
    term_eraseBUFFER
    frmTelnet.Cls
    CurX = 0
    CurY = 0

End Sub

Private Function term_escapeParseArg(S As String) As String
'
'   PopArg takes the next argument (digits up to a ;) and
'   returns it.  It also removes the arg and the ; from
'   the "s"

    Dim I As Integer

    I = InStr(S, ";")
    If I = 0 Then
        term_escapeParseArg = S
        S = ""
    Else
        term_escapeParseArg = Left$(S, I - 1)
        S = Mid$(S, I + 1)
    End If

End Function

Private Sub term_escapeProcess(CH As Byte)

Dim c           As String
Dim yDiff       As Integer
Dim xDiff       As Integer


    c = Chr$(CH)
    If EscString = "" Then
      'No start character yet
      Select Case c
        Case "["
        
        Case "("
        
        Case ")"
        
        Case "#"
        
        Case Chr$(8)             ' embedded backspace
          CurX = CurX - 1
          term_validatecurX
          InEscape = False
        
        Case "7"                 ' save cursor
          'Save cursor position
          SavecurX = CurX
          SavecurY = CurY
          InEscape = False
        
        Case "8"                 ' restore cursor
          'restore cursor position
          CurX = SavecurX
          CurY = SavecurY
          InEscape = False
        
        Case "c"                 ' look at VSIreset()
        
        Case "D"                 ' cursor down
          CurY = CurY + 1
          term_validatecurY
          InEscape = False
        
        Case "E"                 ' next line
          CurY = CurY + 1
          CurX = 0
          term_validatecurY
          term_validatecurX
          InEscape = False
        
        Case "H"                 ' set tab
          tab_table(tabno) = CurY
          tabno = tabno + 1
          InEscape = False
        
        Case "I"                 ' look at bp_ESC_I()
          InEscape = False
        
        Case "M"                 ' cursor up
          CurY = CurY - 1
          term_validatecurY
                
        Case "Z"                 ' send ident
          InEscape = False
        
        Case Else
              'Invalid start of escape sequence
            If frmTelnet.Tracevt100 Then Debug.Print CH
            
            InEscape = False
            Exit Sub
      End Select
    End If

    EscString = EscString & c
    If IsCharAlpha(CH) = 0 Then
        ' Not a character ...
        If Len(EscString) > 15 Then
          If frmTelnet.Tracevt100 Then Debug.Print CH
            InEscape = False
        End If
        Exit Sub
    End If


    Select Case c

        Case "A"

            ' A ==> move cursor up
            
            EscString = Mid$(EscString, 2)

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

            CurY = CurY - yDiff
            term_validatecurY
        
        Case "B"

            ' B ==> move cursor down
            
            EscString = Mid$(EscString, 2)