frmoutput.frm

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

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Object = "{831FDD16-0C5C-11D2-A9FC-0000F8754DA1}#2.0#0"; "MSCOMCTL.OCX"
Begin VB.Form frmOutput 
   AutoRedraw      =   -1  'True
   BorderStyle     =   0  'None
   Caption         =   "推理信息"
   ClientHeight    =   1875
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   5745
   ControlBox      =   0   'False
   LinkTopic       =   "Form1"
   ScaleHeight     =   1875
   ScaleWidth      =   5745
   ShowInTaskbar   =   0   'False
   Tag             =   "推理信息"
   WhatsThisHelp   =   -1  'True
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   4920
      Top             =   1560
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   16777215
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      UseMaskColor    =   0   'False
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   3
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmOutput.frx":0000
            Key             =   ""
         EndProperty
         BeginProperty ListImage2 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmOutput.frx":0752
            Key             =   ""
         EndProperty
         BeginProperty ListImage3 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmOutput.frx":102C
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.ListView LVoutput 
      Height          =   1455
      Left            =   120
      TabIndex        =   0
      Top             =   120
      Width           =   5535
      _ExtentX        =   9763
      _ExtentY        =   2566
      LabelWrap       =   -1  'True
      HideSelection   =   -1  'True
      FullRowSelect   =   -1  'True
      GridLines       =   -1  'True
      _Version        =   393217
      Icons           =   "ImageList1"
      SmallIcons      =   "ImageList1"
      ForeColor       =   -2147483640
      BackColor       =   -2147483643
      BorderStyle     =   1
      Appearance      =   1
      NumItems        =   0
   End
   Begin MSComDlg.CommonDialog dlgCommonDialog 
      Left            =   1440
      Top             =   1560
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
End
Attribute VB_Name = "frmOutput"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Implements IWillDockToActiveBar

Private Sub Form_Load()
LVoutput.View = lvwReport
LVoutput.ColumnHeaders.Add , , "提示"
LVoutput.ColumnHeaders.Add , , "说明", 5000
Form_Resize
End Sub

Private Sub Form_Resize()
LVoutput.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight
End Sub

Private Function IWillDockToActiveBar_DockYourselfTo(ByVal ActiveBar As ActiveBar2LibraryCtl.IActiveBar2, Optional ByVal parmIsVisible As Boolean = True, Optional ByVal paramDockingarea As ActiveBar2LibraryCtl.DockingAreaTypes = 3&, Optional ByVal paramGrabHandleStyle As ActiveBar2LibraryCtl.GrabHandleStyles = 7&, Optional ByVal paramDockingOffset As Long = 0&) As ActiveBar2LibraryCtl.IBand
Dim b As ActiveBar2LibraryCtl.band
Dim t As ActiveBar2LibraryCtl.tool
Dim sBandName As String

On Error GoTo eh_IWillDockToActiveBar_DockYourselfTo


    sBandName = DOCKABLEBANDPREFIXNAME + Me.Name

    '这个可入坞的窗体带区并没有存在，所以创建一个
    Set b = ActiveBar.Bands.Add(sBandName)
        b.Caption = Me.Caption

        b.DockingArea = paramDockingarea
        b.DockLine = 0
        b.DockingOffset = paramDockingOffset

        b.GrabHandleStyle = paramGrabHandleStyle

        b.AutoSizeForms = True
        b.Type = ddBTNormal
        b.DisplayMoreToolsButton = False

        ABAddFlag ddBFSizer, b

        b.Visible = parmIsVisible

    '添加一个可入坞窗体按钮来使这个窗口入坞
    Set t = b.Tools.Add(Me.hWnd, DOCKABLETOOLPREFIXNAME + Me.Name)
        t.ControlType = ddTTForm
        t.Caption = Me.Caption
        Set t.Custom = Me


ex_IWillDockToActiveBar_DockYourselfTo:

Exit Function

eh_IWillDockToActiveBar_DockYourselfTo:

    MsgBox "当入坞时在窗体“" + Me.Name + "”发生错误。"

    Resume ex_IWillDockToActiveBar_DockYourselfTo
End Function

Private Sub LVoutput_DblClick()
Dim str As String
If LVoutput.ListItems.count > 0 Then
    If LVoutput.SelectedItem.Text <> "" Then
        str = InputBox("请修改你选择的项", "Dest3.0", LVoutput.SelectedItem.SubItems(1))
        If str <> "" Then
            LVoutput.SelectedItem.SubItems(1) = str
        End If
    End If
End If
End Sub

Private Sub Lvoutput_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
Dim litem As ListItem
On Error Resume Next
If (Button = 2) Then
    Set litem = LVoutput.HitTest(X, Y)
    LVoutput.ListItems(litem.Index).Selected = True
    fMainForm.ActiveBar.Bands("popupoutput").PopupMenu
End If
End Sub

Public Sub MyPopupMenu(ByVal tool As ActiveBar2LibraryCtl.tool)
Select Case tool.Name
'推理窗口弹出菜单
    Case "ReasonClear":
        ClearWindow
    Case "ReasonShowgrid":
        ShowGrid
    Case "ReasonSaveResult":
        If LVoutput.ListItems.count > 0 Then _
            SaveResult
    Case "ReasonModify":
        If LVoutput.ListItems.count > 0 Then _
            Modify (LVoutput.SelectedItem.Index)
End Select
End Sub

Private Sub ClearWindow()
LVoutput.ListItems.Clear
End Sub

Private Sub ShowGrid()
LVoutput.GridLines = Not LVoutput.GridLines
End Sub

Private Sub Modify(ByRef i As Integer)
Dim str As String
str = InputBox("请修改你选择的项", "Dest3.0", LVoutput.ListItems(i).SubItems(1))
'inputbox
'如果用户单击取消，则函数返回一个零长度字符串 ("")
If str <> "" Then
    LVoutput.SelectedItem.SubItems(1) = str
End If
End Sub

Private Sub SaveResult()
Dim sFile As String
Dim fsoSave As Scripting.FileSystemObject
Dim nSaveQuery As Integer
On Err GoTo errhand:

Me.LVoutput.Refresh
With dlgCommonDialog
    .DialogTitle = "保存"
    .filename = Left(currentXml, Len(currentXml) - 4) + "结论.txt"
    .CancelError = False
    .InitDir = App.path
        'ToDo: set the flags and attributes of the common dialog control
    .Filter = "文本文件 (*.txt)|*.txt|All Files (*.*)|*.*"
    .ShowSave
    If Len(.filename) = 0 Or Err.Number = cdlCancel Then
        Exit Sub
    End If
    sFile = .filename
End With
    Set fsoSave = CreateObject("Scripting.FileSystemObject")
    If (Len(sFile) > 0) Then
        If fsoSave.FileExists(sFile) Then
            nSaveQuery = MsgBox("文件" + dlgCommonDialog.filename + "已存在，覆盖吗？", vbYesNo + vbInformation, "Dest3.0")
                Select Case nSaveQuery
                    Case vbYes
                        ' GO overwrite and quite
                        SaveOutputFile sFile
                    Case vbNo
                        Call SaveResult
                        ' Redisplay the Save dialog
                    Case vbCancel
                        Exit Sub
                End Select
        Else
            SaveOutputFile sFile
        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

Private Sub SaveOutputFile(ByRef sFile As String)
Dim i As Integer
Dim str As String
    Open sFile For Output As #1
        For i = 1 To LVoutput.ListItems.count
            Write #1, LVoutput.ListItems(i).Text + LVoutput.ListItems(i).SubItems(1)
        Next
        MsgBox "结果文件已保存！"
    Close #1
End Sub