frmmain.frm

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

For Each f In Forms
    If f.Caption = filename Then
    tsSave.Write (f.rtfText.Text)
    Exit For
    End If
Next
tsSave.Close
Set fsoSave = Nothing
Set tsSave = Nothing
End Sub

Private Sub SaveProjectFile(ByRef filename As String)
Dim m_string As String
Dim fsoSave As Scripting.FileSystemObject
Dim tsSave As Scripting.TextStream
Set fsoSave = CreateObject("Scripting.FileSystemObject")
Set tsSave = fsoSave.OpenTextFile(filename, ForWriting, True)
m_string = ""
For i = 2 To frmtree.prjTreeView.Nodes.count
    SaveXMLFile (frmtree.prjTreeView.Nodes(i).Tag)
    m_string = m_string + """" + frmtree.prjTreeView.Nodes(i).Text + """" + vbCrLf
Next
tsSave.Write (m_string)
tsSave.Close
Set fsoSave = Nothing
Set tsSave = Nothing
End Sub

'*************************************
'         卸载所有文档
'*************************************
Private Sub UnloadAllDocs()
Dim f As Form
For Each f In Forms
    If TypeOf f Is IMDIDocument Or TypeOf f Is frmBrowser Then
        Unload f
    End If
Next
End Sub

'*************************************
'       设置是否验证XML文档的有效性
'*************************************
Public Sub DocValidity()
If bValidate = False Then
    oDoc.validateOnParse = False
Else
    oDoc.validateOnParse = True
End If
End Sub

Private Sub tbReason_ButtonClick(ByVal Button As MSComctlLib.Button)
On Error Resume Next
    Select Case Button.Key
        Case "Compile"
            mnuFileCompile_Click
        Case "Reason"
            mnuReason_Click
        Case "ReverseReason"
            mnuReverseReason_Click
        Case "EndReason"
            mnuEndReason_Click
    End Select
End Sub



'*************************************
'     添加已存在的带区
'*************************************
Private Sub AddDockedForms()
Dim frm As IWillDockToActiveBar

    ' Dock frmProject
    Set frm = frmtree
    frm.DockYourselfTo ActiveBar, True, ddDARight, ddGSCaption
    
    ' Dock frmImmediate
    Set frm = frmOutput
    frm.DockYourselfTo ActiveBar, True, ddDABottom, ddGSCaption
    
    Set frm = FormDebug
    frm.DockYourselfTo ActiveBar, True, ddDABottom, ddGSCaption
    
    CreateTb
    InitColorTools
    CreatePopupColor
    ActiveBar.RecalcLayout
    
End Sub

Private Sub UpdateToolbar()
    With ActiveBar
        .Tools("miVProjectBar").checked = .Bands(DOCKABLEBANDPREFIXNAME & frmtree.Name).Visible
        .Tools("miVReasonBar").checked = .Bands(DOCKABLEBANDPREFIXNAME & frmOutput.Name).Visible
        .Tools("miVCompileBar").checked = .Bands(DOCKABLEBANDPREFIXNAME & FormDebug.Name).Visible
        .Tools("miVToolBar").checked = .Bands("tbFormat").Visible
        .Tools("miVStatusBar").checked = .Bands("Status Bar").Visible
    End With
End Sub

'*************************************
'     创建 "工具栏" 带区
'*************************************

Private Sub CreateTb()
    Dim oTool As ActiveBar2LibraryCtl.tool, oBand As ActiveBar2LibraryCtl.band
    Dim b As ActiveBar2LibraryCtl.band
    Dim x As Long
    
    '添加“格式”带区
    Set oBand = ActiveBar.Bands.Add("tbFormat")
    
    With oBand
        .Caption = "格式工具栏"
        .WrapTools = True
        .Type = ddBTNormal
        .DockLine = 0
        .Flags = oBand.Flags Or ddBFStretch
        .GrabHandleStyle = ddGSIE
    End With

'添加按钮
    '分隔线
    Set oTool = ActiveBar.Tools.Add(0, "Separator")
    With oTool
        .Caption = ""
        .Category = "格式"
        .ControlType = ddTTSeparator
    End With
    
    '加粗
    Set oTool = ActiveBar.Tools.Add(1, "tbBold")
    With oTool
        .Caption = "加粗"
        .Category = "格式"
        .ToolTipText = "加粗"
        .ControlType = ddTTButton
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoBold.bmp")
    End With
    oBand.Tools.Insert -1, oTool
    
    '倾斜
    Set oTool = ActiveBar.Tools.Add(2, "tbItalic")
    With oTool
        .Caption = "倾斜"
        .Category = "格式"
        .ToolTipText = "倾斜"
        .ControlType = ddTTButton
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoItalic.bmp")
    End With
    oBand.Tools.Insert -1, oTool
    
    '下划线
    Set oTool = ActiveBar.Tools.Add(3, "tbUnderline")
    With oTool
        .Caption = "下划线"
        .Category = "格式"
        .ToolTipText = "下划线"
        .ControlType = ddTTButton
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFOUnderline.bmp")
    End With
    oBand.Tools.Insert -1, oTool
    
    '插入分隔线
    oBand.Tools.Insert -1, ActiveBar.Tools("Separator")
    
    '左对齐
    Set oTool = ActiveBar.Tools.Add(4, "tbLeft")
    With oTool
        .Caption = "左对齐"
        .Category = "格式"
        .ToolTipText = "左对齐"
        .ControlType = ddTTButton
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoLeft.bmp")
    End With
    oBand.Tools.Insert -1, oTool
    
    '居中
    Set oTool = ActiveBar.Tools.Add(5, "tbCenter")
    With oTool
        .Caption = "居中"
        .Category = "格式"
        .ToolTipText = "居中对齐"
        .ControlType = ddTTButton
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoCenter.bmp")
    End With
    oBand.Tools.Insert -1, oTool
    
    '右对齐
    Set oTool = ActiveBar.Tools.Add(6, "tbRight")
    With oTool
        .Caption = "右对齐"
        .Category = "格式"
        .ToolTipText = "右对齐"
        .ControlType = ddTTButton
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoRight.bmp")
    End With
    oBand.Tools.Insert -1, oTool
    
    
    '插入分隔线
    oBand.Tools.Insert -1, ActiveBar.Tools("Separator")
    
    '字体组合框
    Set oTool = ActiveBar.Tools.Add(7, "tbFontName")
    With oTool
        .Caption = "字体"
        .Category = "格式"
        .ToolTipText = "字体"
        .ControlType = ddTTCombobox
        .CBStyle = ddCBSSortedReadOnly
        .Width = 2000
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoFont.bmp")
    End With
    'For X = 0 To Screen.FontCount - 1
    '    oTool.CBAddItem Screen.Fonts(X)
    'Next
    'oTool.Text = rtfText.Font.Name
    oBand.Tools.Insert -1, oTool
    
    '字体大小组合框
    Set oTool = ActiveBar.Tools.Add(8, "tbFontSize")
    With oTool
        .Caption = "字体大小"
        .Category = "格式"
        .ToolTipText = "字号"
        .ControlType = ddTTCombobox
        .CBStyle = ddCBSNormal
        .Width = 600
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\fontsize.bmp")
    End With
    'For X = 4 To 40 Step 2
    '    oTool.CBAddItem X
    'Next
    'oTool.Text = CInt(rtfText.Font.Size)
    oBand.Tools.Insert -1, oTool
    
    '背景颜色按钮
    Set oTool = ActiveBar.Tools.Add(9, "tbBackgroundColor")
    With oTool
        .Caption = "文字颜色"
        .Category = "格式"
        .ToolTipText = "设置颜色"
        .ControlType = ddTTButtonDropDown
        .SetPicture ddITNormal, LoadPicture(App.path & "\icon\miFoColor.bmp")
        .SubBand = "popColors"
    End With
    oBand.Tools.Insert -1, oTool
    
    ActiveBar.RecalcLayout
    'oBand.ChildBandStyle = ddCBSSlidingTabs
    For Each b In oBand.ChildBands
         b.WrapTools = False
    Next b
End Sub
'*************************************
'     创建“颜色”弹出式带区
'*************************************
Private Sub CreatePopupColor()
    Dim tTool As ActiveBar2LibraryCtl.tool, bBand As ActiveBar2LibraryCtl.band
    Dim ColorToolID As Long, i As Long
    
    '设置 ColorToolID 到 2000，那么所有的按钮的编号都在 2000 和 3000 之间
    ColorToolID = 2000
    iColCnt = 0
    
    '“颜色”弹出式带区
    Set bBand = ActiveBar.Bands.Add("popColors")
    With bBand
        .Caption = "颜色弹出带区"
        .Type = ddBTNormal
        .DockingArea = ddDAPopup
        .ToolsVSpacing = 30
        .Flags = 192    '分开且隐藏
        .Height = 2625
        .Width = 2100
    End With
    
    '“自动”按钮
    Set tTool = ActiveBar.Tools.Add(301, "tAutomatic")
    With tTool
        .Caption = "自动"
        .Category = "颜色"
        .checked = True
        .Style = ddSText
        .Width = 2100
        .Visible = True
    End With
    
    '“更多颜色”按钮
    Set tTool = ActiveBar.Tools.Add(302, "tMoreColors")
    With tTool
        .Caption = "更多颜色..."
        .Category = "颜色"
        .Style = ddSText
        .Width = 2100
        .Visible = True
    End With
    
    '颜色按钮
    '循环到颜色数组结束
    For i = 0 To UBound(aColors)
        
        '调用 PaintBackground 程序传递到 PictureBox 和颜色数组
        Call PaintBackGround(Picture1, aColors(iColCnt))
        
        '添加颜色按钮
        '像按钮名称一样使用颜色数组索引
        'This will allow you to easily test for the tool in the ToolClick event
        'ToolClick 事件允许你十分容易地测试按钮
        Set tTool = ActiveBar.Tools.Add(ColorToolID, iColCnt)
        With tTool
            .Caption = "颜色 " & i
            .Category = "颜色"
            .ControlType = ddTTButton
            .Style = ddSIcon
            .SetPicture ddITNormal, Picture1.Image, vbButtonFace
        End With
        bBand.Tools.Insert -1, tTool
        
        '添加当前的编号
        ColorToolID = ColorToolID + 1
        iColCnt = iColCnt + 1
    Next
    
    bBand.Tools.Insert 0, ActiveBar.Tools("tAutomatic")      '插入第一个按钮
    bBand.Tools.Insert -1, ActiveBar.Tools("tMoreColors") '插入到最后
    
    ActiveBar.RecalcLayout
End Sub

Private Sub PaintBackGround(pic As PictureBox, iColor As Long)
    Dim x As Long, y As Long
    
    pic.Height = 200
    pic.Width = 200
    
    '使用填充区域
    For x = 0 To 11
        For y = 0 To 11
            pic.PSet (x, y), iColor
        Next y
    Next x
    
    '绘制边框
    pic.Line (0, 0)-(11, 11), vb3DDKShadow, B
End Sub



Private Sub InitColorTools()
    
    '初始的颜色数组
    aColors(0) = &HFFFFFF
    aColors(1) = &HC0C0FF
    aColors(2) = &HC0E0FF
    aColors(3) = &HC0FFFF
    aColors(4) = &HC0FFC0
    aColors(5) = &HFFFFC0
    aColors(6) = &HFFC0C0
    aColors(7) = &HFFC0FF
    aColors(8) = &HE0E0E0
    aColors(9) = &H8080FF
    aColors(10) = &H80C0FF
    aColors(11) = &H80FFFF
    aColors(12) = &H80FF80
    aColors(13) = &HFFFF80
    aColors(14) = &HFF8080
    aColors(15) = &HFF80FF
    aColors(16) = &HC0C0C0
    aColors(17) = &HFF&
    aColors(18) = &H80FF&
    aColors(19) = &HFFFF&
    aColors(20) = &HFF00&
    aColors(21) = &HFFFF00
    aColors(22) = &HFF0000
    aColors(23) = &HFF00FF
    aColors(24) = &H808080
    aColors(25) = &HC0&
    aColors(26) = &H40C0&
    aColors(27) = &H40C0&
    aColors(28) = &HC000&
    aColors(29) = &HC000&
    aColors(30) = &HC00000
    aColors(31) = &HC000C0
    aColors(32) = &H0&
    aColors(33) = &H40&
    aColors(34) = &H404080
    aColors(35) = &H4040&
    aColors(36) = &H4000&
    aColors(37) = &H404000
    aColors(38) = &H400000
    aColors(39) = &H400040
End Sub

Private Sub TerminateProgram()

Static Unloading As Boolean
Dim idx As Integer

If Unloading Then Exit Sub
Unloading = True
For idx = Forms.count - 1 To 0 Step -1
    Unload Forms(idx)
Next idx
Unloading = False
End Sub

Private Sub DistributedSystem()
Dim formdsystem1 As New FormDSystem
formdsystem1.Show
End Sub