frmdocument.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"
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form frmDocument 
   AutoRedraw      =   -1  'True
   Caption         =   "Document"
   ClientHeight    =   4890
   ClientLeft      =   3690
   ClientTop       =   2340
   ClientWidth     =   5460
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   4890
   ScaleWidth      =   5460
   Begin VB.Timer AutoSaveTimer 
      Interval        =   1000
      Left            =   4680
      Top             =   4200
   End
   Begin VB.Timer tmr 
      Left            =   3840
      Top             =   4080
   End
   Begin MSComDlg.CommonDialog FontDlg 
      Left            =   2640
      Top             =   4080
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
   End
   Begin MSComctlLib.ImageList ImageList1 
      Left            =   960
      Top             =   3960
      _ExtentX        =   1005
      _ExtentY        =   1005
      BackColor       =   -2147483643
      ImageWidth      =   16
      ImageHeight     =   16
      MaskColor       =   12632256
      _Version        =   393216
      BeginProperty Images {2C247F25-8591-11D1-B16A-00C0F0283628} 
         NumListImages   =   1
         BeginProperty ListImage1 {2C247F27-8591-11D1-B16A-00C0F0283628} 
            Picture         =   "frmDocument.frx":0000
            Key             =   ""
         EndProperty
      EndProperty
   End
   Begin MSComctlLib.StatusBar StatusBar1 
      Align           =   2  'Align Bottom
      Height          =   300
      Left            =   0
      TabIndex        =   0
      Top             =   4590
      Width           =   5460
      _ExtentX        =   9631
      _ExtentY        =   529
      _Version        =   393216
      BeginProperty Panels {8E3867A5-8586-11D1-B16A-00C0F0283628} 
         NumPanels       =   2
         BeginProperty Panel1 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Text            =   "行数"
            TextSave        =   "行数"
         EndProperty
         BeginProperty Panel2 {8E3867AB-8586-11D1-B16A-00C0F0283628} 
            Text            =   "列数"
            TextSave        =   "列数"
         EndProperty
      EndProperty
   End
   Begin RichTextLib.RichTextBox rtfText 
      Height          =   4035
      Left            =   0
      TabIndex        =   1
      Top             =   0
      Width           =   4800
      _ExtentX        =   8467
      _ExtentY        =   7117
      _Version        =   393217
      BackColor       =   16777215
      Enabled         =   -1  'True
      ScrollBars      =   3
      Appearance      =   0
      TextRTF         =   $"frmDocument.frx":49F2
   End
End
Attribute VB_Name = "frmDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Dim m_modified As Boolean            '定义文档是否被修改，需要存盘
Dim cursorX As Single                '鼠标位置X,Y
Dim cursorY As Single

Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, _
ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

Private Const WM_USER = &H400
Private Const WM_PASTE = &H302
Private Const WM_COPY = &H301
Private Const WM_CUT = &H300
Private Const EM_UNDO = &HC7
Private Const EM_REDO = (WM_USER + 84)
Private Const EM_CANPASTE = (WM_USER + 50)
Private Const EM_CANREDO = (WM_USER + 85)
Private Const EM_GETUNDONAME = (WM_USER + 86)
Private Const EM_GETREDONAME = (WM_USER + 87)
Private Const EM_GETSEL = &HB0
Private Const EM_LINEINDEX = &HBB
Private Const EM_LINEFROMCHAR = &HC9         'EM_LINEFROMCHAR消息把要传递的字符序号放在参数wParam中:
Const EnterAsc = 13              'AscII码
Const TabAsc = 9
Const BackSpaceAsc = 8

Private m_ab As ActiveBar2LibraryCtl.ActiveBar2
Implements IMDIDocument


'Private Function GetLineFromChar(richtextbox1 As RichTextBox, CharPos As Long) As Long
'GetLineFromChar = SendMessage(richtextbox1.hWnd, EM_LINEFROMCHAR, CharPos, 0&)
'End Function

Private Sub Form_Load()
Me.WindowState = Normal
SetModified (False)
AutoSaveTimer.Enabled = True
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
Dim nSaveQuery, i As Integer
If (GetModified() = True) Then
    nSaveQuery = MsgBox("文档已修改，需要保存吗?" + vbCrLf, vbYesNoCancel, "Dest3.0")
    Select Case nSaveQuery
    Case vbYes
        fMainForm.mnuFileSave_Click
    Case vbNo
    Case vbCancel
        Cancel = -1
    End Select
End If
End Sub

Private Sub rtfText_Change()
SetModified (True)
End Sub


Private Sub rtfText_KeyDown(KeyCode As Integer, Shift As Integer)
Dim LineNo As Long, ColNo As Long
GetCaretPos rtfText.hwnd, LineNo, ColNo
StatusBar1.Panels(1).Text = "第 " + CStr(LineNo) + " 行"
StatusBar1.Panels(2).Text = "第 " + CStr(ColNo) + " 列"
End Sub

Private Sub rtfText_KeyPress(KeyAscii As Integer)
Dim str As String
Dim LineNo As Long, ColNo As Long
GetCaretPos rtfText.hwnd, LineNo, ColNo
str = Chr(KeyAscii)
If str = "<" And bAutoAdd = True Then
    Me.PopupMenu fMainForm.mnuAutoadd, , cursorX, cursorY   '自动列出可选子节点
End If
End Sub

Private Sub rtfText_KeyUp(KeyCode As Integer, Shift As Integer)
Dim LineNo As Long, ColNo As Long
GetCaretPos rtfText.hwnd, LineNo, ColNo
StatusBar1.Panels(1).Text = "第 " + CStr(LineNo) + " 行"
StatusBar1.Panels(2).Text = "第 " + CStr(ColNo) + " 列"
End Sub

Private Sub rtfText_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
On Error Resume Next
cursorX = x
cursorY = y
If Button = vbRightButton Then
    fMainForm.ActiveBar.Bands("popupedit").PopupMenu
End If
End Sub

Private Sub rtfText_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
Dim LineNo As Long, ColNo As Long
GetCaretPos rtfText.hwnd, LineNo, ColNo
StatusBar1.Panels(1).Text = "第 " + CStr(LineNo) + " 行"
StatusBar1.Panels(2).Text = "第 " + CStr(ColNo) + " 列"
End Sub

Private Sub rtfText_SelChange()
   tmr.Enabled = False
   tmr.Enabled = True
   UpdateToolbar
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    rtfText.Move 0, 0, Me.ScaleWidth, Me.ScaleHeight - 300
End Sub

Public Sub SetModified(ByVal modified As Boolean)     '设置文档修改标志
m_modified = modified
End Sub

Public Function GetModified() As Boolean              '读取文档修改标志
GetModified = m_modified
End Function

Private Sub GetCaretPos(ByVal TextHwnd As Long, LineNo As Long, ColNo As Long)
Dim i As Long, j As Long
Dim lParam As Long, wParam As Long
Dim k As Long

'首先向文本框传递EM_GETSEL消息以获取从起始位置到
'光标所在位置的字符数

i = SendMessage(TextHwnd, EM_GETSEL, wParam, lParam)
j = i / 2 ^ 16

'再向文本框传递EM_LINEFROMCHAR消息根据获得的字符
'数确定光标以获取所在行数

LineNo = SendMessage(TextHwnd, EM_LINEFROMCHAR, j, 0)
LineNo = LineNo + 1

'向文本框传递EM_LINEINDEX消息以获取所在列数

k = SendMessage(TextHwnd, EM_LINEINDEX, -1, 0)
ColNo = j - k + 1

End Sub

Private Sub EditSelectAll()
On Error Resume Next
Me.rtfText.SelStart = 0
Me.rtfText.SelLength = Len(Me.rtfText.Text)
End Sub

Private Sub EditPaste()
    On Error Resume Next
    SendMessage rtfText.hwnd, WM_PASTE, 0, 0

End Sub

Private Sub EditCopy()
    On Error Resume Next
    SendMessage rtfText.hwnd, WM_COPY, 0, 0
End Sub

Private Sub EditCut()
    On Error Resume Next
    'Clipboard.SetText Me.rtfText.SelText
    'Me.rtfText.SelText = vbNullString
    SendMessage rtfText.hwnd, WM_CUT, 0, 0
End Sub

Private Sub EditClear()
    On Error Resume Next
    Me.rtfText.SelText = vbNullString
End Sub

Private Sub EditUndo()