frmeditor.frm

用VB实现的编译器的源代码

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmEditor 
   Caption         =   "Source Code"
   ClientHeight    =   6375
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   9015
   BeginProperty Font 
      Name            =   "Tahoma"
      Size            =   8.25
      Charset         =   0
      Weight          =   400
      Underline       =   0   'False
      Italic          =   0   'False
      Strikethrough   =   0   'False
   EndProperty
   Icon            =   "frmEditor.frx":0000
   LinkTopic       =   "Form1"
   ScaleHeight     =   6375
   ScaleWidth      =   9015
   StartUpPosition =   3  'Windows-Standard
   Begin RichTextLib.RichTextBox rtfCode 
      Height          =   5655
      Left            =   0
      TabIndex        =   0
      Top             =   720
      Width           =   9015
      _ExtentX        =   15901
      _ExtentY        =   9975
      _Version        =   393217
      Enabled         =   -1  'True
      HideSelection   =   0   'False
      ScrollBars      =   3
      TextRTF         =   $"frmEditor.frx":058A
      BeginProperty Font {0BE35203-8F91-11CE-9DE3-00AA004BB851} 
         Name            =   "Courier New"
         Size            =   9.75
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
   End
   Begin VB.CommandButton cmdCompile 
      Caption         =   "Build"
      Height          =   495
      Left            =   4440
      Picture         =   "frmEditor.frx":060A
      Style           =   1  'Grafisch
      TabIndex        =   10
      Top             =   120
      Width           =   975
   End
   Begin VB.CommandButton cmdInsert 
      Caption         =   "Insert"
      Height          =   495
      Left            =   3360
      Picture         =   "frmEditor.frx":0B94
      Style           =   1  'Grafisch
      TabIndex        =   9
      Top             =   120
      Width           =   975
   End
   Begin VB.PictureBox picComplete 
      BorderStyle     =   0  'Kein
      Height          =   6135
      Left            =   5520
      ScaleHeight     =   6135
      ScaleWidth      =   3375
      TabIndex        =   4
      Top             =   120
      Width           =   3375
      Begin VB.TextBox txtExamine 
         Appearance      =   0  '2D
         Height          =   285
         Left            =   120
         TabIndex        =   8
         Text            =   "class.method"
         Top             =   5760
         Width           =   3135
      End
      Begin VB.ListBox lstAuto 
         Appearance      =   0  '2D
         Height          =   4515
         Left            =   120
         TabIndex        =   6
         Top             =   600
         Width           =   3135
      End
      Begin VB.Label lblExamine 
         Caption         =   "Examine method... type class and method (class.method) and hit return."
         Height          =   375
         Left            =   120
         TabIndex        =   7
         Top             =   5280
         Width           =   3135
      End
      Begin VB.Label lblInfo 
         Alignment       =   2  'Zentriert
         Caption         =   "Auto Complete"
         Height          =   255
         Left            =   120
         TabIndex        =   5
         Top             =   120
         Width           =   3135
      End
   End
   Begin MSComDlg.CommonDialog cdlOpen 
      Left            =   8400
      Top             =   0
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      CancelError     =   -1  'True
      DialogTitle     =   "Open source code..."
      Filter          =   "b-improved Source Code (*.bis)|*.bis|all files (*.*)|*.*"
   End
   Begin VB.CommandButton cmdLoad 
      Caption         =   "Open"
      Height          =   495
      Left            =   120
      Picture         =   "frmEditor.frx":111E
      Style           =   1  'Grafisch
      TabIndex        =   3
      Top             =   120
      Width           =   975
   End
   Begin VB.Timer tmrRecolor 
      Interval        =   200
      Left            =   7920
      Top             =   0
   End
   Begin VB.CommandButton cmdSyntax 
      Caption         =   "Code Editor"
      Height          =   495
      Left            =   2280
      Picture         =   "frmEditor.frx":16A8
      Style           =   1  'Grafisch
      TabIndex        =   2
      Top             =   120
      Width           =   975
   End
   Begin VB.CommandButton cmdSave 
      Caption         =   "Save"
      Height          =   495
      Left            =   1200
      Picture         =   "frmEditor.frx":1C32
      Style           =   1  'Grafisch
      TabIndex        =   1
      Top             =   120
      Width           =   975
   End
   Begin RichTextLib.RichTextBox rtfMemorysuck 
      Height          =   6135
      Left            =   0
      TabIndex        =   11
      Top             =   720
      Width           =   9015
      _ExtentX        =   15901
      _ExtentY        =   10821
      _Version        =   393217
      TextRTF         =   $"frmEditor.frx":21BC
   End
   Begin VB.Menu mnuContext 
      Caption         =   "Context"
      Visible         =   0   'False
      Begin VB.Menu mnuFX 
         Caption         =   "Framework Class Browser..."
      End
      Begin VB.Menu mnuBar1 
         Caption         =   "-"
      End
      Begin VB.Menu mnuBaseCode 
         Caption         =   "Application Base Code"
      End
      Begin VB.Menu mnuEmptyGrid 
         Caption         =   "Empty Main Class"
      End
   End
End
Attribute VB_Name = "frmEditor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Const C_SYNTAX = "Code Editor"
Const C_PLAIN = "Plain Text"
Dim Expressions, CompilerParams, Keywords, Brackets, Constant, Marks
Dim NoHideMode As Boolean
Dim EditorIndent As Integer

Private Function FirstLine() As String
    On Error Resume Next
    Output = rtfCode.Text
    Output = Left(rtfCode.Text, InStr(rtfCode.Text, vbCrLf) - 1)
    FirstLine = Output
End Function

Private Sub cmdCompile_Click()
    Dim TargetFileName As String
    Suggestion = Left(Me.Tag, InStrRev(Me.Tag, ".") - 1) & ".EXE"
    If Left(FirstLine, 11) = "//Filename=" Then
        Suggestion = Mid(FirstLine, 12)
    End If
    TargetFileName = InputBox("Please enter the name of the .EXE file.", "Build project", Suggestion)
    If TargetFileName = "" Then Exit Sub
    cmdSave_Click
    Shell App.Path & "\Compiler.EXE " & frmMain.txtProject.Text & "\" & TargetFileName & " " & frmMain.txtProject & "\" & Me.Tag, vbNormalFocus
End Sub

Private Sub cmdInsert_Click()
    PopupMenu mnuContext
End Sub

Private Sub cmdLoad_Click()
    On Error GoTo Cp
    cdlOpen.ShowOpen
    rtfCode.LoadFile cdlOpen.FileName
Cp:
End Sub

Private Sub cmdSave_Click()
    On Error GoTo BSlash
Retry:
    Open frmMain.txtProject & "\" & Me.Tag For Output As #1
        Print #1, rtfCode.Text;
    Close #1
    Exit Sub
BSlash:
    frmMain.txtProject.Text = Left(frmMain.txtProject.Text, Len(frmMain.txtProject.Text) - 1)
    Resume Retry
End Sub

Private Sub cmdSyntax_Click()
    Select Case cmdSyntax.Caption
        Case C_PLAIN
            cmdSyntax.Caption = C_SYNTAX
            Me.tmrRecolor.Enabled = True
        Case C_SYNTAX
            cmdSyntax.Caption = C_PLAIN
    End Select
End Sub

Private Sub Form_Load()
    Expressions = Array("assignForm ", "setFormIcon ", "windowLoop", _
        "quitUI", "leave", "addControl ", "set ", "declare ", _
        "messageBox ", "repeat ", "class ", "method ", "end ", "variable ", _
        "global ", "readASCIIToMisc ", "setOutput ", "setInput ", _
        "setAppend ", "write ", "closeFile ", "readLine ", "eof ", "lof ", "selectLogoScreen ", _
        "turtleOn", "turtleOff", "tmove ", "tcls", "tturn ", "tmoveTo ", "tturnTo ", "turtleColor ", _
        "turtleSleep ", "getTY", "getTX", "return ", "turtlePrint ", "actionHandler", "tHide", "tShow", _
        "start ", "stop ", "schedule ", "createSocket ", "connect ", "close ", "assignSocketTalk ", _
        "suppressSocketTalk ", "serveOn ", "streamRead ", "streamWrite ", "streamPeek ", "clientRequest ", _
        "clientAccept ", "socketName ", "if ", "do ", "anchor ", "step ", _
        "while ", "clean ")
    CompilerParams = Array("softThreading", "define", "include ", "implement ", ">>>", "<<<", "delegate ", _
        "console ")
    Keywords = Array("global", "fixed", "flex", "dialog", "tool", "(int)", "(unicode)", "(float)", "(double)", "(long)", "(bool)")
    Brackets = Array("event_", "[", "]", "%0D", "%20", " + ", " - ", " & ", " / ", " * ", _
        " = ", ">>", "<<")
    Constant = Array("cMsgYes", "cMsgNo", "cMsgCancel", "cMsgOK", "cMsgAbort", _
        "cMsgRetry", "cMsgIgnore", "cMsgStModal", "cMsgStQuestion", "cMsgStInfo", _
        "cMsgStExclamation", "cMsgStError", "cMsgStYesNo", "cMsgStYesNoCancel", _
        "cMsgStOKCancel", "cMsgStAbortRetryIgnore", "AppPath", "ScreenXConstant", "ScreenYConstant", _
        "ScreenWidth", "ScreenHeight", "MsgBoxReturn", "Misc", "FreefileNumber", "(srcpath)")
    Marks = Array("<definitions>", "<methods>", "::", ";;", "~", "//")
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    picComplete.ZOrder vbSendToBack
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    cdlOpen.Flags = cdlOFNFileMustExist + cdlOFNPathMustExist
    If Me.Height < 6780 Then Me.Height = 6780
    If Me.Width < 9135 Then Me.Width = 9135
    rtfCode.RightMargin = 9000000
    rtfCode.Height = Me.ScaleHeight - rtfCode.Top
    rtfCode.Width = Me.ScaleWidth
    rtfMemorysuck.Move rtfCode.Left, rtfCode.Top, rtfCode.Width, rtfCode.Height
End Sub

Public Sub AppendLine(Text As String)
    rtfCode.Text = rtfCode.Text & Text & vbCrLf
End Sub

Public Sub HiLight(ReturnPoint, Optional From, Optional Till)
    On Error Resume Next
    picComplete.Visible = False
    rtfMemorysuck.SetFocus
    rtfCode.Visible = False
    Dim i As String
    Dim AlreadySpaced As Boolean
    i = rtfCode.Text
    If IsMissing(From) Then From = 1
    If IsMissing(Till) Then Till = Len(i)
    If From < 1 Then From = 1
    If Till > Len(i) Then Till = Len(i)
        
    Dim Mode As Boolean
    Mode = True
    For f = From To Till
        If Mid(i, f, 1) = Chr(34) Then Mode = Not Mode
        If Mode = True Then
            X = f
            If Mid(i, f, 1) = " " Or Mid(i, f, 1) = vbLf Then AlreadySpaced = True
            If From = 1 And Till = Len(i) Or AlreadySpaced = True Then
                With rtfCode
                    .SelStart = X
                    .SelLength = 1
                    .SelBold = False
                    .SelItalic = False
                    .SelColor = vbBlack
                    .SelLength = 0
                End With
            End If
            Format X, MidX(i, f, CompilerParams), vbRed, False, False
            Format X, MidX(i, f, Constant), RGB(0, 128, 0), False, True
            Format X, MidX(i, f, Expressions), RGB(0, 0, 128), True, False
            Format X, MidX(i, f, Keywords), vbBlue, False, False
            Format X, MidX(i, f, Marks), vbRed, True, True
            Format X, MidX(i, f, Brackets), RGB(128, 0, 0), False, False
        End If
    Next f
    rtfCode.SelStart = ReturnPoint
    rtfCode.SelBold = False: rtfCode.SelItalic = False: rtfCode.SelColor = 0
    rtfCode.Visible = True
    picComplete.Visible = True
    rtfCode.SetFocus
End Sub

Private Sub Format(Position, Length, Color, Bold, Italic)
    If Length = -1 Then Exit Sub
    rtfCode.SelStart = Position - 1: rtfCode.SelLength = Length
    rtfCode.SelColor = Color
    rtfCode.SelBold = Bold
    rtfCode.SelItalic = Italic
    rtfCode.SelLength = 0
    rtfCode.SelStart = rtfCode.SelStart + Length
    rtfCode.SelColor = vbBlack