frmmain.frm

编译原理课程设计用vb编写

        lbLine = lbLine & i & vbCrLf
    Next
End Sub

Private Sub Form_Unload(Cancel As Integer)
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
    End
End Sub

Private Sub mnuDebug_Click()
    runFlag = False
    Call Runit
End Sub

Public Sub mnuStart_Click()
    runFlag = True
    Call Runit
End Sub


Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "新建"
            mnuFileNew_Click
        Case "打开"
            mnuFileOpen_Click
        Case "保存"
            mnuFileSave_Click
        Case "运行"
            Call mnuStart_Click
        Case "调试"
            Call mnuDebug_Click
    End Select
End Sub

Private Sub mnuHelpAbout_Click()
    frmAbout.Show vbModal, Me
End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer
    '如果这个工程没有帮助文件，显示消息给用户
    '可以在“工程属性”对话框中为应用程序设置帮助文件
    If Len(App.HelpFile) = 0 Then
        MsgBox "无法显示帮助目录，该工程没有相关联的帮助。", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = OSWinHelp(Me.hwnd, App.HelpFile, 3, 0)
        If Err Then
            MsgBox Err.Description
        End If
    End If

End Sub


Private Sub mnuViewOptions_Click()
    '应做:添加 'mnuViewOptions_Click' 代码。
    MsgBox "添加 'mnuViewOptions_Click' 代码。"
End Sub

Private Sub mnuViewStatusBar_Click()
    mnuViewStatusBar.Checked = Not mnuViewStatusBar.Checked
    sbStatusBar.Visible = mnuViewStatusBar.Checked
End Sub

Private Sub mnuViewToolbar_Click()
    mnuViewToolbar.Checked = Not mnuViewToolbar.Checked
    tbToolBar.Visible = mnuViewToolbar.Checked
End Sub


Private Sub mnuFileExit_Click()
    '卸载窗体
    mnuFileNew_Click
    End
End Sub



Private Sub mnuFileSaveAs_Click()
    FileSaveAs
End Sub

Private Sub mnuFileSave_Click()
    FileSave
End Sub

Private Sub mnuFileClose_Click()
    Call mnuFileNew_Click
End Sub

Private Sub mnuFileOpen_Click()
    Dim sFile As String
    Call mnuFileNew_Click
    With dlgCommonDialog
        .DialogTitle = "打开"
        .CancelError = False
        'ToDo: 设置 common dialog 控件的标志和属性
        .Filter = "BasicPlus文件 (*.bp,*.bas)|*.bp;*.bas|所有文件(*.*)|*.*"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        sFile = .FileName
    End With
    'ToDo: 添加处理打开的文件的代码
    txtSource.Text = FileRead(sFile)
    globalFileName = sFile
    flagChange = False
End Sub

Private Sub mnuFileNew_Click()
    If flagChange = True Then
        r = MsgBox("内容已经更改,是否保存?", vbQuestion + vbYesNoCancel, "警告")
        If r = vbYes Then
            Call FileSave
        ElseIf r = vbNo Then
            '新建
            Call FileNew
        Else
            Exit Sub
        End If
    End If
    FileNew
End Sub

Private Sub FileNew()
    txtSource.Text = ""
    globalFileName = ""
    flagChange = False
End Sub

Private Sub FileSave()
    If globalFileName = "" Then
        Call FileSaveAs
    Else
        FileWrite globalFileName
    End If
End Sub

Private Sub FileSaveAs()
    With dlgCommonDialog
        .FileName = ""
        .Filter = "BasicPlus文件 (*.bp)|*.bp"
        .ShowSave
        If .FileName = "" Then
            Exit Sub
        Else
            FileWrite .FileName
            globalFileName = .FileName
        End If
    End With
End Sub

Private Sub FileWrite(ByVal name As String)
    Dim Fso As New FileSystemObject
    Dim f As TextStream
    Set f = Fso.OpenTextFile(name, ForWriting, True)
    f.Write txtSource.Text
    f.Close
    flagChange = False
End Sub

Public Function FileRead(ByVal name As String)
    Dim Fso As New FileSystemObject
    Dim f As TextStream
    Set f = Fso.OpenTextFile(name, ForReading, True)
    FileRead = f.ReadAll
    f.Close
    flagChange = False
End Function

Private Sub Timer1_Timer()
    Me.Caption = IIf(globalFileName = "", "[新文件", "[" & globalFileName) & IIf(flagChange, " *", "") & "] - Basic Plus"
    showLine
End Sub

Private Sub Timer2_Timer()
    Static myln As Long
    If myln <> globalln And txtSource.SelLength = 0 Then
        myln = globalln
        CodeFormat
    End If
End Sub

Private Sub txtHide_Change()

End Sub

Private Sub txtSource_Change()
    flagChange = True
End Sub


Private Function showLine()
    s1 = Left(txtSource.Text, txtSource.SelStart)
    ln = Len(s1) - Len(Replace(s1, Chr(13), "")) + 1
    globalln = ln
    sbStatusBar.Panels(1).Text = "当前行号：" & ln
End Function


Private Sub txtSource_Click()
    showLine
End Sub


Private Sub txtSource_KeyPress(KeyAscii As Integer)
    Dim rKeyAscii As Integer
    rKeyAscii = -1
    '自动缩进/突出
    'KeyAscii = 0
    If KeyAscii = 13 Or KeyAscii = 8 Or KeyAscii = 9 Then
        With txtSource
            s1 = Left(.Text, .SelStart)
            s2 = Mid(.Text, .SelStart + 1, Len(.Text))
            If KeyAscii = 8 Then
                If Right(s1, 4) = "    " Then
                    s1 = Left(s1, Len(s1) - 4)
                    .Text = s1 & s2
                    .SelStart = Len(s1)
                Else
                    flag = 1
                End If
            ElseIf KeyAscii = 9 Then
                s1 = s1 & "    "
                .Text = s1 & s2
                .SelStart = Len(s1)
            Else
                If InStr(s1, vbCrLf) = 0 Then
                    st = s1
                Else
                    sts = Split(s1, vbCrLf)
                    st = sts(UBound(sts))
                End If
                If st <> "" Then
                    Do While Left(st, 1) = " "
                        st = Right(st, Len(st) - 1)
                        n = n + 1
                        If st = "" Then Exit Do
                    Loop
                End If
                Dim tl As New clsLine
                tl.strText = Trim(st)
                Select Case tl.Head
                    Case "if", "while", "do while", "select case", "for", "do", "case", "case else", "elseif", "else"
                        n = n + 4
                End Select
                If Right(LCase(tl.Body), 5) <> " then" And tl.Head = "if" Then n = n - 4
                If n < 0 Then n = 0
                .Text = s1 & vbCrLf & String(n, " ") & s2
                .SelStart = Len(s1) + 2 + n
            End If
        End With
        rKeyAscii = 0
        If flag = 1 Then rKeyAscii = 8
    End If
    If rKeyAscii <> -1 Then KeyAscii = rKeyAscii
End Sub

Private Sub CodeFormat()
    With txtSource
        s1 = Left(.Text, .SelStart)
        s2 = Mid(.Text, .SelStart + 1, Len(.Text))
        s1s = Split(s1, vbCrLf)
        s2s = Split(s2, vbCrLf)
        If UBound(s1s) > 0 Then
            For i = 0 To UBound(s1s) - 1
                tmp = s1s(i)
                spacenum = Len(tmp) - Len(LTrim(tmp))
                tmp = String(spacenum, " ") & FormatPlus(tmp)
                ns1 = ns1 & tmp & vbCrLf
            Next
            ns1 = ns1 & s1s(UBound(s1s))
        Else
            ns1 = ns1 & s1
        End If
        
        If UBound(s2s) > 0 Then
            ns2 = ns2 & s2s(0) & vbCrLf
            For i = 1 To UBound(s2s)
                tmp = s2s(i)
                spacenum = Len(tmp) - Len(LTrim(tmp))
                If Trim(tmp) = "" Then
                    tmp = FormatPlus(tmp)
                Else
                    tmp = String(spacenum, " ") & FormatPlus(tmp)
                End If
                ns2 = ns2 & tmp & vbCrLf
            Next
            ns2 = Left(ns2, Len(ns2) - 2)
        Else
            ns2 = ns2 & s2
        End If
        .Text = ns1 & ns2
        .SelStart = Len(ns1)
    End With
End Sub


Private Sub txtSource_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer2.Enabled = False
End Sub

Private Sub txtSource_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    Timer2.Enabled = True
End Sub