frmmain.frm

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

      Begin VB.Menu mnuWindowArrangeIcons 
         Caption         =   "排列图标(&A)"
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助(&H)"
      Begin VB.Menu mnuHelpContents 
         Caption         =   "内容(&C)"
      End
      Begin VB.Menu mnuHelpSearchForHelpOn 
         Caption         =   "搜索(&S)..."
      End
      Begin VB.Menu mnuTechnicalSupport 
         Caption         =   "技术支持..."
      End
      Begin VB.Menu mnuHelpBar0 
         Caption         =   "-"
      End
      Begin VB.Menu mnuHelpAbout 
         Caption         =   "关于(&A)"
      End
   End
   Begin VB.Menu mnuAutoadd 
      Caption         =   "自动插入子菜单"
      Begin VB.Menu mnuAutoadd1 
         Caption         =   "PROJECT"
      End
      Begin VB.Menu mnuAutoadd2 
         Caption         =   "OBJECT"
      End
      Begin VB.Menu mnuAutoadd3 
         Caption         =   "ATTRIBUTE"
      End
      Begin VB.Menu mnuAutoadd4 
         Caption         =   "METHOD"
      End
      Begin VB.Menu mnuAutoadd5 
         Caption         =   "SELECT"
      End
      Begin VB.Menu mnuAutoadd6 
         Caption         =   "REASON"
      End
      Begin VB.Menu mnuAutoadd7 
         Caption         =   "WRITE"
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Type SHELLEXECUTEINFO
    cbSize As Long
    fMask As Long
    hwnd As Long
    lpVerb As String
    lpFile As String
    lpParameters As String
    lpDirectory As String
    nShow As Long
    hInstApp As Long
    lpIDList As Long
    lpClass As String
    hkeyClass As Long
    dwHotKey As Long
    hIcon As Long
    hProcess As Long
End Type
Private Declare Function ShellExecuteEX Lib "Shell32" Alias "ShellExecuteEx" (lpSEI As SHELLEXECUTEINFO) As Long
Private Declare Function HtmlHelpA Lib "hhctrl.ocx" (ByVal hwndCaller As Long, ByVal pszFile As String, ByVal uCommand As Long, ByVal dwData As Long) As Long
Private Const SEE_MASK_INVOKEIDLIST = &HC
Private m_bFontsLoaded As Boolean
Private bLoaded As Boolean                     '标识是否载入XML文档
Private bExistProj As Boolean         '设置当前是否已经有工程存在
Private newPrjLoc As String


'*************************************
'     创建“字体”与“字号”下拉选项
'*************************************
Private Sub ActiveBar_ComboDrop(ByVal tool As ActiveBar2LibraryCtl.tool)
    If tool.Name = "tbFontName" Or tool.Name = "tbFontSize" Then
        If Not m_bFontsLoaded Then
            FillFontCombos
            m_bFontsLoaded = True
        End If
    End If
End Sub

'*************************************
'     下拉框改变字体和字号
'*************************************
Private Sub ActiveBar_ComboSelChange(ByVal tool As ActiveBar2LibraryCtl.tool)
    If Not ActiveForm Is Nothing Then
    If TypeOf ActiveForm Is IMDIDocument Then
        If tool.Name = "tbFontName" Then
            ActiveForm.rtfText.SelFontName = tool.Text
        ElseIf tool.Name = "tbFontSize" Then
            ActiveForm.rtfText.SelFontSize = Val(tool.Text)
        End If
    End If
    End If
End Sub
'*************************************
'     填充字体与字号下拉框
'*************************************
Private Sub FillFontCombos()
Dim i As Integer
    With ActiveBar.Tools("tbFontName")
        For i = 1 To Screen.FontCount
            .CBAddItem Screen.Fonts(i)
        Next
    End With
    With ActiveBar.Tools("tbFontSize")
        .CBAddItem " 8"
        .CBAddItem " 9"
        .CBAddItem "10"
        .CBAddItem "11"
        .CBAddItem "12"
        .CBAddItem "14"
        .CBAddItem "16"
        .CBAddItem "18"
        .CBAddItem "20"
        .CBAddItem "22"
        .CBAddItem "24"
        .CBAddItem "26"
        .CBAddItem "28"
        .CBAddItem "36"
        .CBAddItem "48"
    End With
End Sub
'*************************************
'
'*************************************
Private Sub ActiveBar_ToolClick(ByVal tool As ActiveBar2LibraryCtl.tool)
Dim doc As IMDIDocument
If Not currentCtl Is Nothing Then
    If TypeOf currentCtl Is RichTextBox Then
        If Not ActiveForm Is Nothing Then
            If TypeOf ActiveForm Is IMDIDocument Then
                Set doc = ActiveForm
                If doc.CommandHandler(tool) Then Exit Sub
            End If
        End If
    ElseIf TypeOf currentCtl Is TextBox Then
        Select Case tool.Name
            Case "miECut"
                Clipboard.SetText currentCtl.SelText
                currentCtl.SelText = ""
            Case "miEPaste"
                currentCtl.SelText = Clipboard.GetText
            Case "miEClear"
                    SendKeys "{Del}"
            Case "miECopy"
                Clipboard.SetText currentCtl.SelText
        End Select
    End If
End If

If (tool.Category = "推理窗口弹出菜单") Then
    frmOutput.MyPopupMenu tool
    Exit Sub
End If
If (tool.Category = "调试窗口弹出菜单") Then
    FormDebug.MyPopupMenu tool
    Exit Sub
End If

    Select Case tool.Name
    '文件
    Case "miFNew": mnuFileNew_Click
    Case "miFOpen": mnuFileOpen_Click
    Case "miFSave": mnuFileSave_Click
    Case "miFSaveas": mnuFileSaveAs_Click
    Case "miFAttribute": mnuFileProperty_Click
    Case "miExit": mnuFileExit_Click
    '工程
    Case "miPNew": mnuNewProject_Click
    Case "miPOpen": mnuOpenProject_Click
    Case "miPSave": mnuProjectSave_Click
    Case "miPSaveas": mnuProjectSaveas_Click
    Case "miPRemove": mnuRemovePrj_Click
    '插入
    Case "miIDTD": mnuInsertDTD_Click
    Case "miIOther":
    
    '知识文件管理
    Case "miPAddFile": mnuAddKnowledge_Click
    Case "miPDeleteFile": mnuDeleteKnowledge_Click
    Case "miPFileSaveas": mnuFileSaveAs_Click
    Case "miPSaveFile": mnuFileSave_Click
    Case "miPExportFile": mnuExportKnowledge_Click
    Case "miPPreviewFile": mnuNetPageShow_Click
    '视图
    Case "miVProjectBar": ViewProjectBar
    Case "miVReasonBar":  ViewReasonBar
    Case "miVCompileBar": ViewCompileBar
    Case "miVToolBar":   ViewToolBar
    Case "miVStatusBar": ViewStatusBar
    Case "miVOptions":   ViewOptions
    
    '窗口
    Case "miWNew": mnuWindowNewWindow_Click
    Case "miWCommon":
    Case "miWTileH": mnuWindowTileHorizontal_Click
    Case "miWTileV": mnuWindowTileVertical_Click
    Case "miWCascade": mnuWindowCascade_Click
    Case "miWArrangeIcons": mnuWindowArrangeIcons_Click
    
    '帮助
    Case "miHContents": mnuHelpContents_Click
    Case "miHTechnicalSupport": mnuTechnicalSupport_Click
    Case "miHSearch": mnuHelpSearchForHelpOn_Click
    Case "miAbout": mnuHelpAbout_Click
    
    '推理
    Case "miReasonCompile": mnuFileCompile_Click
    Case "miReason": mnuReason_Click
    Case "miReasonReverse": mnuReverseReason_Click
    Case "miReasonEnd": mnuEndReason_Click
    '工具
    Case "miTColDetect": CollisionDetect
    Case "miTAHP": mnuAHP_Click
    Case "miTScheme": SchemeManager
    Case "miD": DistributedSystem
    Case "miTOption": ViewOptions
    '知识获取
    Case "miTVisualInput": mnuknowinput_Click
    Case "miTLearn": mnuLearn_Click
    
    End Select
    
    UpdateToolbar
End Sub
'*************************************
'       主窗口初始化
'*************************************
Private Sub MDIForm_Load()
    '一个程序只允许运行一个实例
    Dim Title As String
    If App.PrevInstance = True Then
    Title = App.Title
    Call MsgBox("程序已执行，且只能执行一个", vbInformation)
    App.Title = ""
    AppActivate Title
    Unload Me
    End If
    
    AddDockedForms
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 6500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
   
    Me.WindowState = vbMaximized
    bAutoAdd = True     '自动添加功能打开
    ActiveBar.XPLook = True
    bExistProj = False  '标记程序启动未打开工程
    FileNum = 0
    Set oDoc = New DOMDocument
    outputflag = 0
    
End Sub

'*************************************
'       '初始化文档并且显示窗体
'*************************************
Public Sub LoadNewDoc()
    Dim i As Integer
    i = iDoc
    Set frmD(i) = New frmDocument
    frmD(i).Caption = "Document" + CStr(i + 1)
    frmD(i).Tag = "Document" + CStr(i + 1)

    Dim doc As IMDIDocument
    Set doc = frmD(i)
    iDoc = iDoc + 1
    
    doc.InitDoc ActiveBar, "Document" & CStr(iDoc), True
End Sub

Private Sub MDIForm_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim nSaveQuery As Integer
nSaveQuery = MsgBox("确认要退出程序吗？" + vbCrLf, vbYesNo, "Dest3.0")
If nSaveQuery = vbNo Then
    Cancel = -1
Else
    UnloadAllForms
End If
End Sub

Private Sub UnloadAllForms()
Dim aForm As Form
For Each aForm In Forms
    Unload aForm
    Set aForm = Nothing
Next aForm
End Sub


'*************************************
'       '对当前工程添加知识文档
'*************************************
Private Sub mnuAddKnowledge_Click()
If bExistProj = True Then
    frmAddKnowledge.Show
Else
    MsgBox "请先建立或打开一个工程!", vbInformation, "Dest3.0"
End If
End Sub

'***************************************
'        层次分析前处理子程序
'***************************************
Private Sub mnuAHP_Click()
Dim str As String
str = InputBox("请输入层次分析的层数(介于2-5之间的整数)：", "Dest3.0")
Do
If str = "" Then '表示用户选择cancel
    Exit Sub
End If
If (IsNumeric(str)) Then
    Select Case str
    Case 2
        Layer = CInt(str)
        Exit Do
    Case 3
        Layer = CInt(str)
        Exit Do
    Case 4
        Layer = CInt(str)
        Exit Do
    Case 5
        Layer = CInt(str)
        Exit Do
    Case Else
        str = InputBox("输入错误!" + Chr(13) + "请重新输入层数 (介于2--5之间的整数)", "Dest3.0")
    End Select
Else
    str = InputBox("输入错误!" + Chr(13) + "请重新输入层数(介于2--5之间的整数)", "Dest3.0")
End If
Loop
frmAHPInput.Show
End Sub

'*************************************
'       '自动添加子功能(在添加中)
'*************************************
Private Sub mnuAutoadd1_Click()

    Clipboard.SetText "<PROJECT></PROJECT>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
    
End Sub

Private Sub mnuAutoadd2_Click()

    Clipboard.SetText "<OBJECT></OBJECT>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
End Sub

Private Sub mnuAutoadd3_Click()

    Clipboard.SetText "<ATTRIBUTE></ATTRIBUTE>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
End Sub

Private Sub mnuAutoadd4_Click()

    Clipboard.SetText "<METHOD></METHOD>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
End Sub

Private Sub mnuAutoadd5_Click()

    Clipboard.SetText "<SELECT></SELECT>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
End Sub

Private Sub mnuAutoadd6_Click()

    Clipboard.SetText "<REASON></REASON>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
End Sub

Private Sub mnuAutoadd7_Click()

    Clipboard.SetText "<WRITE></WRITE>"
    
    ActiveForm.rtfText.SelText = Clipboard.GetText
End Sub


'*************************************
'       '在当前工程中删除选定的知识文档
'*************************************
Public Sub mnuDeleteKnowledge_Click()
Dim i As Integer
If Not ActiveForm Is Nothing Then
If (frmtree.prjTreeView.Nodes.count = 2) Then
    MsgBox "工程不能为空", vbInformation, "Dest3.0"
    Exit Sub
End If
If (frmtree.prjTreeView.SelectedItem.Index > 1) Then
    frmtree.prjTreeView.Nodes.Remove (frmtree.prjTreeView.SelectedItem.Index)
    FileNum = FileNum - 1
Else
    Exit Sub
End If
Open sPrj For Output As #1