frmeditor.frm

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

    rtfCode.SelBold = False
    rtfCode.SelItalic = False
End Sub

Private Function MidX(Expression As String, ByRef Position, CheckArray) As Integer
    On Error Resume Next
    MidX = -1
    For f = LBound(CheckArray) To UBound(CheckArray)
        If Mid(Expression, Position, Len(CheckArray(f))) = CheckArray(f) Then
            MidX = Len(CheckArray(f))
            Position = Position + MidX - 1
            Exit Function
        End If
    Next f
End Function

Private Sub lblInfo_Click()
    picComplete.ZOrder vbBringToFront
End Sub

Private Sub lblInfo_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    picComplete.ZOrder vbBringToFront
    AutoComplete
End Sub

Private Sub lstAuto_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    picComplete.ZOrder vbSendToBack
    If Not lstAuto.Text = "" Then
        P = Split(lstAuto.Text, "'")
        rtfCode.SelText = P(1)
    End If
    rtfCode.SetFocus
    NoHideMode = False
End Sub

Private Sub lstAuto_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        picComplete.ZOrder vbSendToBack
        If Not lstAuto.Text = "" Then
            P = Split(lstAuto.Text, "'")
            rtfCode.SelText = P(1)
        End If
        rtfCode.SetFocus
        NoHideMode = False
    End If
End Sub

Private Sub mnuBaseCode_Click()
    NewCode = "//Filename=[EnterFileName].EXE<br>" & _
                "//EnSystems Application Template<br>" & _
                "include fxVariables.bis<br><br>" & _
                "global<br>" & _
                "  //Global variables<br>" & _
                "end global<br><br>" & _
                "class AppMain<br>" & _
                "  <br>" & _
                "  <definitions><br>" & _
                "  <br>" & _
                "  variable misc<br>" & _
                "    Variant;;<br>" & _
                "    [+Misc];;<br>" & _
                "  end variable<br>" & _
                "  <br>" & _
                "  method run<br>" & _
                "    0;;<br>" & _
                "  end method<br>" & _
                "  <br>" & _
                "  <methods><br>" & _
                "  <br>" & _
                "  method void run<br>" & _
                "    //Insert your own code here<br>" & _
                "  end method<br><br>" & _
                "end class"
    NewCode = Replace(NewCode, "<br>", vbCrLf)
    rtfCode.SelText = NewCode
End Sub

Private Sub mnuEmptyGrid_Click()
    NewCode = "//Filename=[EnterFileName].EXE<br>" & _
                "include fxVariables.bis<br><br>" & _
                "class AppMain<br>" & _
                "  <br>" & _
                "  <definitions><br>" & _
                "  <br>" & _
                "  <methods><br>" & _
                "  <br>" & _
                "  method void run<br>" & _
                "    //Insert your own code here<br>" & _
                "  end method<br><br>" & _
                "end class"
    NewCode = Replace(NewCode, "<br>", vbCrLf)
    rtfCode.SelText = NewCode
End Sub

Private Sub mnuFX_Click()
    Dim fFramework As frmFramework
    Set fFramework = New frmFramework
    Set fFramework.Owner = Me
    fFramework.Show
End Sub

Private Sub picComplete_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    picComplete.ZOrder vbBringToFront
    AutoComplete
End Sub

Private Sub AutoComplete()
    On Error Resume Next
    lstAuto.Clear
    CW = CurrentWord
    If Left(CW, 1) = "+" Then
        ListAllPublicVars Mid(CW, 2), rtfCode.Text
    ElseIf Right(CW, 1) = "." Then
        ListAllMembers Left(CW, Len(CW) - 1), rtfCode.Text
    End If
End Sub

Private Function GetIncludeFile(IncludeLine As String)
    INCNAME$ = Mid(IncludeLine, 9)
    INCNAME = Replace(INCNAME, "(srcpath)", frmMain.txtProject.Text)
    If Not Mid(INCNAME, 2, 1) = ":" Then
        INCNAME = App.Path & "\" & INCNAME
    End If
    Output = ""
    Open INCNAME For Input As #3
        Do Until EOF(3)
            Line Input #3, SoftLine
            Output = Output & SoftLine & vbCrLf
        Loop
    Close #3
    GetIncludeFile = Output
End Function

Private Sub ListAllMembers(MembersOf, SourceText As String)
    If Left(MembersOf, 1) = "[" Then MembersOf = Mid(MembersOf, 2)
    If Left(MembersOf, 1) = ":" Then MembersOf = Mid(MembersOf, 2)
    ResolvedBase = GetBObjectType(MembersOf, SourceText)
    i = Replace(SourceText, vbCrLf, vbLf)
    P = Split(i, vbLf)
    Mode = False
    For f = LBound(P) To UBound(P)
        If Len(P(f)) > Len("include") Then
            If Left(P(f), Len("include")) = "include" Then
              ListAllMembers ResolvedBase, GetIncludeFile(CStr(P(f)))
            End If
        End If
    Next f
    For f = LBound(P) To UBound(P)
        P(f) = Trim(P(f))
        If P(f) = "end class" Then Mode = False
        If P(f) = "class " & ResolvedBase Then Mode = True
        If Mode = True Then
            If P(f) Like "declare *" Then
                X = Split(P(f), " ")
                lstAuto.AddItem "Property '" & X(1)
            End If
            If P(f) Like "variable *" Then
                X = Split(P(f), " ")
                lstAuto.AddItem "Property '" & X(1)
            End If
            If P(f) Like "method void *" Then
                X = Split(P(f), " ")
                lstAuto.AddItem "Void '" & X(2)
            End If
            If P(f) Like "method function *" Then
                X = Split(P(f), " ")
                lstAuto.AddItem "Function '" & X(2)
            End If
        End If
    Next
End Sub

Private Function GetBObjectType(ObjectName, SourceText As String)
    If ObjectName = "this" Then
        LastClass = InStrRev(rtfCode.Text, "class ", rtfCode.SelStart)
        ReturnVal = Mid(rtfCode.Text, LastClass + Len("class "))
        ReturnVal = Replace(ReturnVal, vbCrLf, vbLf)
        ReturnVal = Left(ReturnVal, InStr(ReturnVal, vbLf) - 1)
        GetBObjectType = ReturnVal
        Exit Function
    End If
    i = Replace(SourceText, vbCrLf, vbLf)
    P = Split(i, vbLf)
    Dim X As String
    For f = LBound(P) To UBound(P)
        X = CStr(Trim(P(f)))
        If X = "class " & ObjectName Then GetBObjectType = ObjectName
        If CStr(X) Like "set global " & ObjectName & " ??N?*" Then
            X = Mid(X, InStr(X, ":") + 1)
            X = Left(X, Len(X) - 1)
            GetBObjectType = X
        End If
    Next
End Function

Private Sub ListAllPublicVars(Beginning, SourceText)
    On Error Resume Next
    i = Replace(SourceText, vbCrLf, vbLf)
    P = Split(i, vbLf)
    For f = LBound(P) To UBound(P)
        If Len(P(f)) > Len("include") Then
            If Left(P(f), Len("include")) = "include" Then
              ListAllPublicVars Beginning, GetIncludeFile(CStr(P(f)))
            End If
        End If
    Next f
    For f = LBound(Constant) To UBound(Constant)
        If Left(Constant(f), Len(Beginning)) = Beginning Then
            lstAuto.AddItem Left(Constant(f), Len(Beginning)) & "'" & Mid(Constant(f), Len(Beginning) + 1)
        End If
    Next
    For f = LBound(P) To UBound(P)
        P(f) = Trim(P(f))
        If P(f) = "global" Then Mode = True
        If Mode = True And Left(P(f), 8) = "variable" Then
            X = Mid(P(f), 10)
            If Left(X, Len(Beginning)) = Beginning Then
                lstAuto.AddItem Left(X, Len(Beginning)) & "'" & Mid(X, Len(Beginning) + 1)
            End If
        End If
        If P(f) = "end global" Then Mode = False
    Next f
End Sub

Private Function CurrentWord() As String
    On Error Resume Next
    i = rtfCode.Text
    P = rtfCode.SelStart
    i = Left(i, P)
    S = InStrRev(i, " ")
    i = Trim(Mid(i, S))
    CurrentWord = i
End Function

Private Sub rtfCode_KeyDown(KeyCode As Integer, Shift As Integer)
    On Error Resume Next
    If Shift = vbCtrlMask Then
        If KeyCode = vbKey1 Then
            EditorIndent = 2
        ElseIf KeyCode = vbKey2 Then
            EditorIndent = 4
        ElseIf KeyCode = vbKey3 Then
            EditorIndent = 6
        ElseIf KeyCode = vbKey4 Then
            EditorIndent = 8
        ElseIf KeyCode = vbKey5 Then
            EditorIndent = 10
        ElseIf KeyCode = vbKeyB Then
            cmdCompile_Click
        ElseIf KeyCode = vbKeyR Then
            Suggestion = Left(Me.Tag, InStrRev(Me.Tag, ".") - 1) & ".EXE"
            If Left(FirstLine, 11) = "//Filename=" Then
                Suggestion = Mid(FirstLine, 12)
            End If
            Shell frmMain.txtProject.Text & "\" & Suggestion
        ElseIf KeyCode = vbKey0 Then
            EditorIndent = 0
        ElseIf KeyCode = vbKeyQ Then
            picComplete.ZOrder vbBringToFront
            NoHideMode = True
            AutoComplete
            lstAuto.SetFocus
            tmrRecolor.Enabled = False
        ElseIf KeyCode = vbKeyX Then
            Clipboard.Clear
            Clipboard.SetText rtfCode.SelText
            rtfCode.SelText = ""
        ElseIf KeyCode = vbKeyC Then
            Clipboard.Clear
            Clipboard.SetText rtfCode.SelText
        ElseIf KeyCode = vbKeyV Then
            rtfCode.SelText = Clipboard.GetText
        End If
        KeyCode = 0
    End If
End Sub

Private Sub rtfCode_KeyPress(KeyAscii As Integer)
    rtfMemorysuck.TextRTF = rtfCode.TextRTF
    rtfMemorysuck.SelStart = rtfCode.SelStart
    If KeyAscii = 13 Then
        KeyAscii = 0
        rtfCode.SelText = vbCrLf
        rtfCode.SelText = Space(EditorIndent)
    End If
End Sub

Private Sub rtfCode_KeyUp(KeyCode As Integer, Shift As Integer)
    If rtfCode.SelLength = 0 Then HiLight rtfCode.SelStart, rtfCode.SelStart - 15, rtfCode.SelStart + 15
End Sub

Private Sub rtfCode_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If NoHideMode = False Then picComplete.ZOrder vbSendToBack
End Sub

Private Sub rtfCode_OLECompleteDrag(Effect As Long)
    Effect = ccOLEDropEffectCopy
End Sub

Private Sub tmrRecolor_Timer()
    tmrRecolor.Enabled = False
    rtfCode.SelStart = i
    rtfCode.SelStart = 1
    rtfCode.SelLength = Len(rtfCode.Text)
    rtfCode.SelBold = False
    rtfCode.SelItalic = False
    rtfCode.SelColor = vbBlack
    If cmdSyntax.Caption = C_SYNTAX Then HiLight i
End Sub

Private Sub txtExamine_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        KeyAscii = 0
        Y = Split(txtExamine.Text, ".")
        ExamObj = Y(0)
        ExamMethod = Y(1)
        i = Replace(rtfCode.Text, vbCrLf, vbLf)
        P = Split(i, vbLf)
        Mode = False
        For f = LBound(P) To UBound(P)
            P(f) = Trim(P(f))
            If P(f) = "end class" Then Mode = False
            If P(f) = "class " & ExamObj Then Mode = True
            If ExamObj = "*" Then Mode = True
            If Mode = True Then
                If P(f) = "method " & ExamMethod Then
                    NUM = CInt(Trim(P(f + 1)))
                    For g = 1 To NUM
                        txtExamine.Text = txtExamine.Text & " [" & Trim(P(f + 1 + g)) & "]"
                    Next g
                End If
            End If
        Next f
    End If
End Sub

Private Sub txtFont_Change()
    On Error Resume Next
    rtfCode.SelFontName = txtFont.Text
    txtFont.FontName = txtFont.Text
End Sub