frmmain.frm

老外用VB写的CNC仿真程序源码

    
    
End Sub
Private Sub mnuRunStepInto_Click()
    mnuRunStepInto.Checked = Not mnuRunStepInto.Checked
    Toolbar.Buttons.Item("Step").Value = IIf(mnuRunStepInto.Checked, tbrPressed, tbrUnpressed)
'    SaveButtonLastState = Toolbar.Buttons.Item("Save").Enabled
'    Call EnableDisableButtons("New,Open,Save,Print,Step,Start,Stop,Options", False)
'    Call EnableDisableButtons("Pause", True)
'
'    mnuFile.Enabled = False
'    mnuView.Enabled = False
'    mnuTools.Enabled = False
'    mnuHelp.Enabled = False
'    TextEditor.Locked = True
'
'    MsgBox "Call Func"
'
'    TextEditor.Locked = False
'    EnableDisableButtons "Start,Stop,Step", True
'    EnableDisableButtons "Pause", False
End Sub

Public Sub mnuRunStop_Click()
    Toolbar.Buttons.Item("Save").Enabled = SaveButtonLastState
    Call EnableDisableButtons("New,Open,Print,Start,Step,Options", True)
    Call EnableDisableButtons("Pause,Stop", False)
    mnuFile.Enabled = True
    mnuView.Enabled = True
    mnuTools.Enabled = True
    mnuHelp.Enabled = True
    TextEditor.Locked = False
    StopSimulation = True
    RemoveHighLighting CurrentLineNumber
    CurrentLineNumber = 0
    ToX = 0
    FromX = 0
    ToZ = 0
    FromZ = 0

    PlayWav App.path & "\sound\stop.wav"
End Sub

Private Sub mnuToolBarCustomize_Click()
    Toolbar.Customize
End Sub

Private Sub mnuToolLibrary_Click()
    frmToolSelect.Show 1
End Sub

Private Sub mnuToolsOptions_Click()
    frmMain.Tag = ""
    Load frmOptions
    frmOptions.Show 1
    If frmMain.Tag = "OK" Then
        TextBuffer.Text = TextEditor.Text
        Call Coloring
        Call SetMainMemory
        picSim.BackColor = SimWindow.BackColor
        Call SetDebugWindow
        Dim i As Integer
        DebugWindow.Col = 2
        For i = 0 To DebugWindow.Rows - 1
            DebugWindow.Row = i
            DebugWindow.CellFontSize = Debuger.FontSize
            DebugWindow.CellFontName = Debuger.FontName
            DebugWindow.RowHeight(i) = Debuger.RowHeight
            Select Case DebugWindow.TextMatrix(i, 3)
                Case "":
                    DebugWindow.CellForeColor = Debuger.NormalTextColor
                    DebugWindow.CellBackColor = Debuger.NormalBackColor
                Case "BP":
                    DebugWindow.CellForeColor = Debuger.BreakPointTextColor
                    DebugWindow.CellBackColor = Debuger.BreakPointColor
            End Select
        Next i
        
    End If
End Sub

Private Sub CopyCodeToDebugWindow() 'OK
    Dim txt() As String
    Dim i As Integer
    txt = Split(TextEditor.Text, vbCrLf)
    DebugWindow.Rows = UBound(txt) + 1
    For i = 0 To UBound(txt)
        DebugWindow.TextMatrix(i, 0) = i + 1    'Setting Line Numbers
        DebugWindow.TextMatrix(i, 2) = txt(i)   'Code Text
        DebugWindow.TextMatrix(i, 3) = ""       'Clearing Break Points
        'Setting Normal Back and Text color{
        DebugWindow.Row = i
        DebugWindow.Col = 2
        DebugWindow.CellBackColor = Debuger.NormalBackColor
        DebugWindow.CellForeColor = Debuger.NormalTextColor
        DebugWindow.CellFontName = Debuger.FontName
        DebugWindow.CellFontSize = Debuger.FontSize
        DebugWindow.CellFontBold = False '}
        'SettingRowHeight{
        DebugWindow.RowHeight(i) = Debuger.RowHeight '}
        'Margins Back Color{
        DebugWindow.Col = 1
        DebugWindow.CellBackColor = RGB(240, 240, 240) '}
        'Removing Prvevious Pictures{
        Set DebugWindow.CellPicture = LoadPicture("") '}
    Next i
End Sub

Private Sub DebugWindow_Click() 'OK
    DebugWindow.ToolTipText = DebugWindow.TextMatrix(DebugWindow.MouseRow, 2)
    If DebugWindow.MouseCol = 1 Then
        With DebugWindow
            .Row = DebugWindow.MouseRow
            .Col = 1
            If .TextMatrix(.MouseRow, 3) = "" Then
                Set .CellPicture = imgListDebugWindow.ListImages("Break").Picture   'Setting Breakpoint Icon
                DebugWindow.CellPictureAlignment = flexAlignCenterCenter            'Aligning picture to centre
                .TextMatrix(.MouseRow, 3) = "BP"                                    'Setting Break Point
                'Set cell's text format{
                .Col = 2
                .CellBackColor = Debuger.BreakPointColor
                .CellForeColor = Debuger.BreakPointTextColor
                .CellFontBold = True '}
                
            ElseIf .TextMatrix(.MouseRow, 3) = "BP" Then
                Set .CellPicture = LoadPicture("")      'Removing Break Point
                .TextMatrix(.MouseRow, 3) = ""          'Clearing Break point
                'Clearing text format{
                .Col = 2
                .CellBackColor = Debuger.NormalBackColor
                .CellForeColor = Debuger.NormalTextColor
                .CellFontBold = False '}
            End If
        End With
    End If
End Sub




Private Sub Form_Paint() 'OK
    
    Slider.Visible = StatusBar.Visible
    ProgressBar.Visible = StatusBar.Visible

If FormPainted = False Then
    'Placing ProgressBar at StatusBar{
    With ProgressBar
        .Width = StatusBar.Panels("ProgressBar").Width - 10
        .Top = StatusBar.Top + 6
        .Left = StatusBar.Panels("ProgressBar").Left + 5
        .Height = StatusBar.Height / 1.5
    End With '}
    
    'Placing Slider at StatusBar{
    With Slider
        .Width = StatusBar.Panels("Slider").Width - 10
        .Top = StatusBar.Top + 6
        .Left = StatusBar.Panels("Slider").Left + 5
        .Height = StatusBar.Height / 1.5
    End With '}
    FormPainted = True
End If
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) 'OK
    If Toolbar.Buttons.Item("Save").Enabled = True Then
        Dim ans As String
        ans = MsgBox("Save changes to " & StatusBar.Panels("FileName").Text & "?", vbQuestion + vbYesNoCancel, "Save Changes?")
        If ans = vbCancel Then
            Cancel = True
            Exit Sub
        End If
        If ans = vbYes Then
            Call mnuFileSave_Click
            If Toolbar.Buttons.Item("Save").Enabled = True Then  'save main cancel
                Cancel = True
                Exit Sub
           End If
        End If
    End If
    Unload Me
    End
End Sub

Private Sub SetDebugWindow() 'OK
    DebugWindow.ColWidth(0) = Debuger.C0Width * Debuger.LineNumbers
    DebugWindow.ColWidth(1) = Debuger.C1Width
    DebugWindow.ColWidth(2) = Debuger.C2Width
    DebugWindow.ColWidth(3) = 0
    DebugWindow.Font = Debuger.FontName
    If Debuger.Grid Then
        DebugWindow.GridLines = flexGridFlat
    Else
        DebugWindow.GridLines = flexGridNone
    End If

End Sub

Private Sub Form_Unload(Cancel As Integer)
    End
End Sub

Private Sub mnuFileNew_Click() 'OK
On Error GoTo Err
    If Toolbar.Buttons.Item("Save").Enabled = True Then
        Dim ans As String
        ans = MsgBox("Save changes to " & StatusBar.Panels("FileName").Text & "?", vbQuestion + vbYesNoCancel, "Save Changes?")
        If ans = vbCancel Then Exit Sub
        If ans = vbYes Then
            Call mnuFileSave_Click
            If Toolbar.Buttons.Item("Save").Enabled = True Then Exit Sub    'save main cancel
        End If
    End If
    TextEditor.Text = ""
    DebugWindow.Rows = 1
    If mnuViewTextEditor.Checked = False Then
        mnuViewTextEditor_Click
    End If
    StatusBar.Panels("FileName").Text = "Untitled"
    Call EnableDisableButtons("Save,Print,Start,Step,Pause,Stop", False)
    picSim.Cls
    TextEditor.SetFocus
    Exit Sub
Err:
    MsgBox Err.Description, vbCritical + vbOKOnly, "Error!"
End Sub

Private Sub mnuFilePrint_Click()
    '
End Sub

Private Sub mnuFileSave_Click() 'OK
    If StatusBar.Panels("FileName") = "Untitled" Then
        Call mnuFileSaveAs_Click
    Else
        TextEditor.SaveFile GetSetting("CNC", "RecentFilePaths", "0"), vbCFText
        EnableDisableButtons "Save", False
    End If
End Sub

Private Sub mnuFileSaveAs_Click() 'OK
On Error GoTo Err
    com.CancelError = True
    com.flags = cdlOFNOverwritePrompt Or cdlOFNPathMustExist Or cdlOFNFileMustExist Or cdlOFNNoChangeDir
    com.Filter = ("CNC Code Files|*.cnc|All Files|*.*")
    com.ShowSave
    TextEditor.SaveFile com.fileName, vbCFText
    Call EnableDisableButtons("Save", False)
    StatusBar.Panels("FileName").Text = GetFileName(com.fileName)
    Call ChangeRecentFilesList(com.fileName, -1)
Err:
End Sub



Private Sub mnuFileOpen_Click() 'OK
On Error GoTo Err
    If Toolbar.Buttons.Item("Save").Enabled = True Then
        Dim ans As String
        ans = MsgBox("Save changes to " & StatusBar.Panels("FileName").Text & "?", vbQuestion + vbYesNoCancel, "Save Changes?")
        If ans = vbCancel Then Exit Sub
        If ans = vbYes Then
            Call mnuFileSave_Click
            If Toolbar.Buttons.Item("Save").Enabled = True Then Exit Sub 'Agar saveas function mein cancel kardiya hai to
        End If
    End If

    com.flags = cdlOFNOverwritePrompt Or cdlOFNPathMustExist Or cdlOFNFileMustExist Or cdlOFNNoChangeDir
    com.Filter = ("CNC Code Files|*.cnc|All Files|*.*")
    com.ShowOpen
    TextBuffer.LoadFile com.fileName, vbCFText
    Call Coloring
    Call EnableDisableButtons("Start,Print,Step", True)
    StatusBar.Panels("FileName").Text = GetFileName(com.fileName)
    Call ChangeRecentFilesList(com.fileName, -1)
    Call CopyCodeToDebugWindow
    TextChanged = False
    Exit Sub
Err:
    MsgBox Err.Description, vbCritical + vbOKOnly, "Error!"
End Sub

'to add/update entries in recent file list
Private Sub ChangeRecentFilesList(ByVal fileName As String, ByVal Index As Integer)
    'index ka use hai ki agar recent files main click kiya hai, to usko top par le aayega, index = -1
    Dim i As Integer, j As Integer
    Dim TempName As String
    If Index <> -1 Then 'not in list
        TempName = GetSetting("CNC", "RecentFilePaths", CStr(Index))
        For i = Index - 1 To 0 Step -1  'shift downwards
            SaveSetting "CNC", "RecentFilePaths", CStr(i + 1), GetSetting("CNC", "RecentFilePaths", CStr(i))
        Next i
        
        SaveSetting "CNC", "RecentFilePaths", "0", TempName 'add new file at top
        Call GetRecentFilesList 'update menu
        Exit Sub
    End If
    
    'file present in list already
    Dim nItems As Menu
    
    'get number of menu items
    For Each nItems In mnuFileRecentFiles
        If InStr(1, nItems.Caption, fileName, vbTextCompare) > 0 Then Exit Sub 'file already present in list
        i = i + 1
    Next
    
    i = i - 1 'since i is index
    
    'no files present
    If i = 0 And mnuFileRecentFiles(0).Caption = "Recent Files" Then
        SaveSetting "CNC", "RecentFilePaths", "0", fileName   'add at top
        Call GetRecentFilesList 'Update menu
        Exit Sub
    End If
    
    'files present, shift downwards
    'item j+1 <- item j
    For j = i To 0 Step -1
        SaveSetting "CNC", "RecentFilePaths", j + 1, GetSetting("CNC", "RecentFilePaths", j)
    Next
    
    SaveSetting "CNC", "RecentFilePaths", "0", fileName 'add recent file to top of menu
    Call GetRecentFilesList 'update menu
End Sub

'Textbox ki coloring kar deta hai or usiko vapis kar deta hai
Private Sub Coloring()
On Error GoTo Err
    Dim i As Integer, k%
    TextBuffer.SelStart = 0
    TextBuffer.SelLength = Len(TextBuffer.Text)
    TextBuffer.SelBold = Editor.Bold
    TextBuffer.SelFontName = Editor.FontName
    TextBuffer.SelFontSize = Editor.FontSize
    For i = 1 To Len(TextBuffer.Text)
        TextBuffer.SelStart = i - 1
        TextBuffer.SelLength = 1
        Select Case TextBuffer.SelText
            Case "["
                k = InStr(i, TextBuffer.Text, vbCrLf)
                TextBuffer.SelStart = i - 1
                TextBuffer.SelLength = k - i
                TextBuffer.SelColor = Editor.CommentsColor
                i = k
            Case "A" To "Z", "a" To "z"
                TextBuffer.SelColor = Editor.CharacterColor
            Case "0" To "9", "-", " ", "."
                TextBuffer.SelColor = Editor.IntegerColor
        End Select
    Next i
    TextEditor.TextRTF = TextBuffer.TextRTF
    TextEditor.BackColor = Editor.BackgroundColor
    Call EnableDisableButtons("Save", False)
    Exit Sub
Err:
    MsgBox Err.Description
End Sub

'sirf file ka name return karega pure path mein se
Private Function GetFileName(ByVal FilePath As String) As String
    Dim j%
    j = InStrRev(FilePath, "\")
    GetFileName = Right$(FilePath, Len(FilePath) - j)
End Function

Private Sub mnuToolBarShowLabels_Click()
    mnuToolBarShowLabels.Checked = Not mnuToolBarShowLabels.Checked
    If mnuToolBarShowLabels.Checked Then
        Toolbar.Buttons.Item("New").Caption = "New"
        Toolbar.Buttons.Item("Open").Caption = "Open"
        Toolbar.Buttons.Item("Save").Caption = "Save"
        Toolbar.Buttons.Item("Print").Caption = "Print"
        Toolbar.Buttons.Item("Step").Caption = "Step"
        Toolbar.Buttons.Item("Start").Caption = "Start"
        Toolbar.Buttons.Item("Pause").Caption = "Pause"
        Toolbar.Buttons.Item("Stop").Caption = "Stop"
        Toolbar.Buttons.Item("Options").Caption = "Options"
    Else
        Toolbar.Buttons.Item("New").Caption = ""
        Toolbar.Buttons.Item("Open").Caption = ""
        Toolbar.Buttons.Item("Save").Caption = ""
        Toolbar.Buttons.Item("Print").Caption = ""
        Toolbar.Buttons.Item("Step").Caption = ""
        Toolbar.Buttons.Item("Start").Caption = ""
        Toolbar.Buttons.Item("Pause").Caption = ""
        Toolbar.Buttons.Item("Stop").Caption = ""
        Toolbar.Buttons.Item("Options").Caption = ""
    End If
    DoEvents
    Call AdjustFormControls
    DoEvents
    Call SaveSetting("CNC", "Toolbar", "ShowLabels", mnuToolBarShowLabels.Checked)
End Sub



Private Sub mnuToolsPlaySound_Click()