frmmain.frm

用XML做专家系统的一个编译器,有说明书,使用简单,有模板

    Dim nRet As Integer
    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = HtmlHelpA(Me.hwnd, App.path & "\dest3help.CHM", 0, 0)
        If Err Then
'            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuHelpContents_Click()
    Dim nRet As Integer

    'if there is no helpfile for this project display a message to the user
    'you can set the HelpFile for your application in the
    'Project Properties dialog
    If Len(App.HelpFile) = 0 Then
        MsgBox "Unable to display Help Contents. There is no Help associated with this project.", vbInformation, Me.Caption
    Else
        On Error Resume Next
        nRet = HtmlHelpA(Me.hwnd, App.path & "\dest3help.CHM", 0, 0)
        If Err Then
'            MsgBox Err.Description
        End If
    End If

End Sub

Private Sub mnuWindowArrangeIcons_Click()
    Me.Arrange vbArrangeIcons
End Sub

Private Sub mnuWindowTileVertical_Click()
    Me.Arrange vbTileVertical
End Sub

Private Sub mnuWindowTileHorizontal_Click()
    Me.Arrange vbTileHorizontal
End Sub

Private Sub mnuWindowCascade_Click()
    Me.Arrange vbCascade
End Sub

Private Sub mnuWindowNewWindow_Click()
    LoadNewDoc
End Sub

Private Sub mnuToolsOptions_Click()
    frmOptions.Show vbModal, Me
End Sub

Private Sub ViewOptions()
    frmOptions.Show vbModal, Me
End Sub

Private Sub mnuViewRefresh_Click()
    fMainForm.ActiveForm.Refresh
    frmOutput.Refresh
    frmtree.Refresh
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
    CoolBar1.Visible = mnuViewToolbar.checked
End Sub

Private Sub mnuEditPasteSpecial_Click()
    'ToDo: Add 'mnuEditPasteSpecial_Click' code.
    MsgBox "Add 'mnuEditPasteSpecial_Click' code."
End Sub

Private Sub mnuEditPaste_Click()
    On Error Resume Next
    ActiveForm.rtfText.SelText = Clipboard.GetText

End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelText

End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.SetText ActiveForm.rtfText.SelText
    ActiveForm.rtfText.SelText = vbNullString

End Sub

Private Sub mnuEditUndo_Click()
    On Error Resume Next
    'SendMessage ActiveForm.rtfText.hWnd, EM_UNDO, 0&, 0&
End Sub

Private Sub mnuFileSend_Click()
    MsgBox "Add 'mnuFileSend_Click' code."
End Sub

Private Sub mnuFilePrint_Click()
    On Error Resume Next
    If ActiveForm Is Nothing Then Exit Sub

    With dlgCommonDialog
        .DialogTitle = "Print"
        .CancelError = False
        .Flags = cdlPDReturnDC + cdlPDNoPageNums
        If ActiveForm.rtfText.SelLength = 0 Then
            .Flags = .Flags + cdlPDAllPages
        Else
            .Flags = .Flags + cdlPDSelection
        End If
        .ShowPrinter
        If Err <> MSComDlg.cdlCancel Then
            ActiveForm.rtfText.SelPrint .hdc
        End If
    End With

End Sub

Private Sub mnuFilePageSetup_Click()
    On Error Resume Next
    With dlgCommonDialog
        .DialogTitle = "Page Setup"
        .CancelError = False
        .ShowPrinter
    End With

End Sub

'*************************************
'       '显示当前文档的属性
'*************************************

Private Sub mnuFileProperty_Click()
    'ToDo: Add 'mnuFileProperties_Click' code.
Dim str As String
If Not ActiveForm Is Nothing Then
    If (Right(ActiveForm.Caption, 3) = "xml" Or Right(ActiveForm.Caption, 3) = "prj") Then
        str = ActiveForm.Caption
        ShowFileProperties (str)
    End If
End If
End Sub

'*************************************
'       '显示文档属性子程序
'*************************************

Private Sub ShowFileProperties(ByVal aFile As String)

Dim SEI As SHELLEXECUTEINFO

SEI.hwnd = Me.hwnd

SEI.lpVerb = "properties"

SEI.lpFile = aFile

SEI.fMask = SEE_MASK_INVOKEIDLIST

SEI.cbSize = Len(SEI)

ShellExecuteEX SEI

End Sub

Private Sub mnuFileSaveAll_Click()
    'ToDo: Add 'mnuFileSaveAll_Click' code.
    MsgBox "Add 'mnuFileSaveAll_Click' code."
End Sub

'*************************************
'       '另外保存当前文档
'*************************************

Private Sub mnuFileSaveAs_Click()
On Error GoTo errhand
    Dim sFile As String
    Dim strFilename  As String
    Dim fsoSave As Scripting.FileSystemObject
    Dim nSaveQuery As Integer

    If ActiveForm Is Nothing Then Exit Sub
    With dlgCommonDialog
        .Flags = cdlOFNPathMustExist
        .filename = ActiveForm.Caption
        .DialogTitle = "文件另存为"
        .CancelError = True
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "PRJ Files (*.prj)|*.prj|XML Files (*.xml)|*.xml|Text Files (*.txt)|*.txt|All Files (*.*)|*.*"
        .ShowSave
        If Err.Number = cdlCancel Then Exit Sub
        If Len(.filename) = 0 Then Exit Sub
        sFile = .filename
        'ActiveForm.Caption = .Filename
    End With
    
    Set fsoSave = CreateObject("Scripting.FileSystemObject")
    If (Len(sFile) > 0) Then
        If Len(ActiveForm.rtfText.Text) <= 0 Then
            MsgBox "用户未输入知识！"
            sFile = ""
        Else
            If fsoSave.FileExists(sFile) Then           '该文件名已存在
                nSaveQuery = MsgBox("文件" + sFile + "已存在，覆盖吗？", vbYesNo + vbInformation, "Dest3.0")
                Select Case nSaveQuery
                    Case vbYes
                        ' GO overwrite and quite
                        SaveXMLFile (sFile)
                    Case vbNo
                        Call mnuFileSaveAs_Click
                        ' Redisplay the Save dialog
                End Select
            Else
                SaveXMLFile (sFile)
            End If
        End If
    End If
errhand:
    If (Err.Number <> 0) And (Err.Number <> cdlCancel) Then
       MsgBox "Error: " & Err.Description, vbExclamation, "Error saving  file"
    End If
    Set fsoSave = Nothing

End Sub

'*************************************
'       '保存当前文档
'*************************************

Public Sub mnuFileSave_Click()
    On Error GoTo errhand
    Dim sFile As String
    If Left$(ActiveForm.Caption, 8) = "Document" Then  'New Document
        With dlgCommonDialog
            .filename = ActiveForm.Caption
            .DialogTitle = "Save"
            .CancelError = True
            'ToDo: set the flags and attributes of the common dialog control
            .Filter = "XML Files (*.xml)|*.xml|PRJ Files (*.prj)|*.prj|Dtd Files (*.dtd)|*.dtd|Text Files (*.txt)|*.txt|All Files (*.*)|*.*"
            .ShowSave
            If Err.Number = cdlCancel Then Exit Sub
            If Len(.filename) = 0 Then
                Exit Sub
            End If
            sFile = .filename
        End With
        SaveNewFile sFile
    Else
        sFile = ActiveForm.Caption               'Exist Document
        SaveXMLFile sFile
    End If
    ActiveForm.SetModified (False)
errhand:
    If (Err.Number <> 0) And (Err.Number <> cdlCancel) Then
       MsgBox "Error: " & Err.Description, vbExclamation, "Error saving  file"
    End If
End Sub


'*************************************
'     打开一个或多个文件 子程序
'*************************************
Private Sub mnuFileOpen_Click()
    On Error GoTo errhand
    Dim sFile As String
    Dim tempStr() As String
    Dim i As Integer
    With dlgCommonDialog
        .Flags = cdlOFNAllowMultiselect
        .DialogTitle = "打开文件"
        .CancelError = True
        'ToDo: set the flags and attributes of the common dialog control
        .Filter = "PRJ Files (*.prj)|*.prj|XML Files (*.xml)|*.xml|DTD Files (*.dtd)|*.dtd|Text Files (*.txt)|*.txt|All Files (*.*)|*.*"
        .ShowOpen
        If Len(.filename) = 0 Then Exit Sub
        tempStr() = Split(.filename)
    End With
    frmtree.SSTab1.Tab = 0
    If (UBound(tempStr) = 0) Then            '只打开一个文件
        LoadNewDoc
        ActiveForm.WindowState = vbMaximized
        ActiveForm.rtfText.LoadFile tempStr(0), rtfText
        ActiveForm.SetModified (False)
        ActiveForm.Caption = tempStr(0)
        ActiveForm.Tag = dlgCommonDialog.FileTitle
    Else
    For i = 1 To UBound(tempStr)             '打开多个文件
        LoadNewDoc
        ActiveForm.rtfText.LoadFile tempStr(0) + tempStr(i), rtfText
        ActiveForm.Caption = tempStr(0) + tempStr(i)
        ActiveForm.Tag = tempStr(i)
    Next
    End If
errhand:
    If Err.Number = cdlCancel Then
        Exit Sub
    End If
    If (Err.Number <> 0) And (Err.Number <> cdlCancel) Then
       MsgBox "Error: " & Err.Description, vbExclamation, "Error open file"
    End If
End Sub

'***************************************
'        新建文件 子程序
'***************************************
Private Sub mnuFileNew_Click()
    frmNew.Show
End Sub


'***************************************
'        建立工程树型目录子程序
'***************************************
Public Function Build_PrjTree() As Boolean
Dim Text As String
Dim i As Integer
Dim root As Node
Dim nodX() As Node
    FormResult.MSFlexGrid1.Clear
    frmtree.prjTreeView.Nodes.Clear
    ReDim nodX(FileNum)
    frmtree.prjTreeView.LineStyle = tvwRootLines
    Set root = frmtree.prjTreeView.Nodes.Add(, , , "Project (" + Prj_Name + ")", 2, 2)
    i = 1
    Do While (sXML(i) <> "")
        LoadNewDoc
        ActiveForm.rtfText.LoadFile Prj_Location + sXML(i), rtfText
        ActiveForm.Caption = Prj_Location + sXML(i)
        ActiveForm.Tag = sXML(i)
        ActiveForm.SetModified (False)
        Text = sXML(i)
        Set nodX(i - 1) = frmtree.prjTreeView.Nodes.Add(root, tvwChild, , Text, 3, 3)
        nodX(i - 1).Tag = Prj_Location + sXML(i)
    i = i + 1
    Loop
    frmtree.prjTreeView.Nodes.item(1).Expanded = True
    frmtree.Refresh
    bExistProj = True
End Function

'***************************************
'        窗口排列子程序
'***************************************
Public Function CommonWindow()
'On Error Resume Next
'If (frmtree.TreeExist() = True) Then
'    frmtree.Left = Me.Width - frmtree.Width - 100
'    frmtree.Top = 0
'    frmtree.Height = Me.Height - Me.CoolBar1.Height - Me.sbStatusBar.Height - 700
'    For Each f In Forms
'        If (Right(f.Caption, 4) = ".xml" Or Right(f.Caption, 4) = "(IE)") And f.WindowState = Normal Then
'            f.Height = frmtree.Height
'            f.Top = frmtree.Top
'            f.Left = 0
'            f.Width = Me.Width - frmtree.Width - 100
'        End If
'    Next
'End If
End Function

'***************************************
'        进度条子程序
'***************************************
'Private Sub ProgressBar()
'Dim intBarvalue As Integer
'ProgressBar1.max = CInt(1000)
'ProgressBar1.Min = CInt(0)
'For intBarvalue = ProgressBar1.Min To ProgressBar1.max
'ProgressBar1.value = intBarvalue
'DoEvents
'Next
'ProgressBar1.value = ProgressBar1.Min
'Exit Sub
'End Sub

'***************************************
'        保存新建文档子程序
'***************************************

Private Sub SaveNewFile(ByRef filename As String)
Dim fsoSave As Scripting.FileSystemObject
Dim tsSave As Scripting.TextStream
Set fsoSave = CreateObject("Scripting.FileSystemObject")
Set tsSave = fsoSave.OpenTextFile(filename, ForWriting, True)
If Not ActiveForm Is Nothing Then
    If TypeOf ActiveForm Is IMDIDocument Then
        tsSave.Write (fMainForm.ActiveForm.rtfText.Text)
    End If
End If
tsSave.Close
Set fsoSave = Nothing
Set tsSave = Nothing

End Sub

'***************************************
'        保存已存在的文档子程序
'***************************************
Public Sub SaveXMLFile(ByRef filename As String)
Dim f As Form
Dim fsoSave As Scripting.FileSystemObject
Dim tsSave As Scripting.TextStream
Set fsoSave = CreateObject("Scripting.FileSystemObject")
Set tsSave = fsoSave.OpenTextFile(filename, ForWriting, True)