frmdocument.frm

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

    On Error Resume Next
    SendMessage Me.rtfText.hwnd, EM_UNDO, 0&, 0&
End Sub

Private Sub EditRedo()
    SendMessage Me.rtfText.hwnd, EM_REDO, 0, 0
End Sub

Private Sub EditFind()
    frmFind.Show
End Sub

Private Sub EditFindNext()
    If frmFind.cbFind <> "" Then
        frmFindForm.cmdFindNext.value = True
    End If
    frmFind.Show
End Sub

Private Sub EditReplace()
    With frmFind
        .cbReplace.Enabled = True '使能够替换
        .lblReplace.Enabled = True '使能够替换
        .Show vbModal '显示为有模式的
    End With
End Sub

Private Sub FormatAlign(intIndex As Integer)
    Select Case intIndex
        Case 0 '左对齐
            '设置对齐方式
            rtfText.SelAlignment = rtfLeft
        Case 1 '居中
            '设置对齐方式
            rtfText.SelAlignment = rtfCenter
        Case 2 '右对齐
            '设置图片
            '设置对齐方式
            rtfText.SelAlignment = rtfRight
    End Select
End Sub
Private Sub FormatFont()
On Error GoTo errhand
FontDlg.CancelError = True
FontDlg.Flags = cdlCFScreenFonts
FontDlg.FontName = "MS Sans Serif"
FontDlg.FontSize = "8"
FontDlg.ShowFont

With rtfText
    .SelFontName = FontDlg.FontName
    .SelFontSize = FontDlg.FontSize
    .SelItalic = FontDlg.FontItalic
    .SelBold = FontDlg.FontBold
    .SelUnderline = FontDlg.FontUnderline
    .SelStrikeThru = FontDlg.FontStrikethru
End With
errhand: Exit Sub
End Sub

Private Sub FormatParagraph()
    frmParagraph.Show vbModal
End Sub

Private Sub FormatBold()
    With rtfText
        If (IsNull(.SelBold) = True) Or (.SelBold = False) Then
            '若所选的文本为加粗的或混合的就设置为加粗
            .SelBold = True
        ElseIf .SelBold = True Then
            '若所选的文本为加粗的就设置取消加粗格式
            .SelBold = False
        End If
        .SetFocus
    End With
End Sub

Private Sub FormatItalic()
    With rtfText
        If (IsNull(.SelItalic) = True) Or (.SelItalic = False) Then
            '若所选的文本为倾斜的或混合的就设置为倾斜
            .SelItalic = True
        ElseIf .SelItalic = True Then
            '若所选的文本为倾斜的就设置取消倾斜格式
            .SelItalic = False
        End If
'        .SetFocus
    End With
End Sub

Private Sub FormatUnderline()
    With rtfText
        If (IsNull(.SelUnderline) = True) Or (.SelUnderline = False) Then
            '若所选的文本为下划线的或混合的就设置为下划线
            .SelUnderline = True
        ElseIf .SelUnderline = True Then
            '若所选的文本为下划线的就设置取消下划线格式
            .SelUnderline = False
        End If
'        .SetFocus
    End With
End Sub

Private Sub FormatColor(tool As ActiveBar2LibraryCtl.tool)
    Select Case tool.Name
        '颜色按钮名称是索引数组
        Case 0 To 9, 10 To 50
            rtfText.SelColor = aColors(CLng(tool.Name))
        '“自动”按钮
        Case "tAutomatic"
            tool.checked = IIf(tool.checked, False, True)
        '“更多颜色”按钮
        Case "tMoreColors"
            MsgBox "从 VB 颜色对话框中显示更多的颜色", vbYes + vbInformation, "Dest3.0"""
    End Select
End Sub
Private Sub FormatBullets()
    With rtfText
        If (IsNull(.SelBullet) = True) Or (.SelBullet = False) Then
            '若所选的文本为项目符号文本的或混合的就设置为项目符号文本
            .SelBullet = True
        ElseIf .SelBullet = True Then
            '若所选的文本为项目符号文本的就设置取消项目符号格式
            .SelBullet = False
            .SelHangingIndent = False
        End If
    End With
End Sub

Private Sub rtftext_GotFocus()
    Set currentCtl = rtfText
End Sub

Private Sub rtftext_LostFocus()
    Set currentCtl = Nothing
End Sub

Private Function IMDIDocument_InitDoc(ab As ActiveBar2LibraryCtl.IActiveBar2, sFile As String, bNew As Boolean) As Boolean
Dim bRet As Boolean
    If Not ab Is Nothing Then
        Set m_ab = ab
        bRet = True
    End If
    If bNew Then
        rtfText.Text = ""
    End If
    rtfText.DataChanged = False
    Caption = sFile
    Me.Show
    IMDIDocument_InitDoc = bRet
End Function

Private Function IMDIDocument_CommandHandler(tool As ActiveBar2LibraryCtl.ITool) As Boolean
    
    IMDIDocument_CommandHandler = True
    If tool.Category = "颜色" Then
        FormatColor tool
        Exit Function
    End If
    Select Case tool.Name
    '文件
    'Case "miFSave": FileSave Me.Caption
    'Case "miFSaveAs": FileSaveAs
    'Case "miFPrint": FilePrint
    'Case "miFPrintPreview": FilePrintPreview
    'Case "miFPageSetup": FilePageSetup
    
    '编辑
    Case "miEUndo": EditUndo
    Case "miERedo": EditRedo
    Case "miECut": EditCut
    Case "miECopy": EditCopy
    Case "miEPaste": EditPaste
    Case "miEClear": EditClear
    Case "miESelectAll": EditSelectAll
    Case "miEFind": EditFind
    Case "miEFindNext": EditFindNext
    Case "miEReplace": EditReplace
    
    '插入
    'Case "miIDate": InsertDate
    'Case "miITime": InsertTime
    'Case "miIPicture": InsertPicture
    
    '工具栏
    Case "tbBold": FormatBold
    Case "tbItalic": FormatItalic
    Case "tbUnderline": FormatUnderline
    Case "tbLeft": FormatAlign 0
    Case "tbCenter": FormatAlign 1
    Case "tbRight": FormatAlign 2
    'Case "tbFontName":
    'Case "tbFontSize":
    
    '格式
    Case "miFoFont": FormatFont
    Case "miFoParagraph": FormatParagraph
    Case "miFoBold": FormatBold
    Case "miFoItalic": FormatItalic
    Case "miFoUnderline": FormatUnderline
    Case "miFoColor": FormatColor tool
    Case "miFoLeft": FormatAlign 0
    Case "miFoCenter": FormatAlign 1
    Case "miFoRight": FormatAlign 2
    'Case "miFoBullets": FormatBullets
    'Case "miFoTabs": FormatTabs
    Case Else
        IMDIDocument_CommandHandler = False
    End Select
    UpdateToolbar
    tmr.Enabled = False
End Function

Private Sub UpdateToolbar()
    With m_ab
        .Tools("miFoBold").checked = IsNull(rtfText.SelBold) Or rtfText.SelBold
        .Tools("tbBold").checked = .Tools("miFoBold").checked
        .Tools("miFoItalic").checked = IsNull(rtfText.SelItalic) Or rtfText.SelItalic
        .Tools("tbItalic").checked = .Tools("miFoItalic").checked
        .Tools("miFoUnderline").checked = IsNull(rtfText.SelUnderline) Or rtfText.SelUnderline
        .Tools("tbUnderline").checked = .Tools("miFoUnderline").checked
        .Tools("miECut").Enabled = (rtfText.SelLength <> 0)
        .Tools("miECopy").Enabled = (rtfText.SelLength <> 0)
        .Tools("miEPaste").Enabled = (SendMessage(rtfText.hwnd, EM_CANPASTE, 0, 0) = 1)
        .Tools("miEUndo").Enabled = (SendMessage(rtfText.hwnd, EM_CANUNDO, 0, 0) = 1)
        .Tools("miERedo").Enabled = (SendMessage(rtfText.hwnd, EM_CANREDO, 0, 0) = 1)
        
        .Tools("miFoLeft").checked = (rtfText.SelAlignment = 0)
        .Tools("tbLeft").checked = .Tools("miFoLeft").checked
        .Tools("miFoCenter").checked = (rtfText.SelAlignment = 2)
        .Tools("tbCenter").checked = .Tools("miFoCenter").checked
        .Tools("miFoRight").checked = (rtfText.SelAlignment = 1)
        .Tools("tbRight").checked = .Tools("miFoRight").checked
        
       '.Tools("miFoBullets").checked = IIf(IsNull(rtfText.SelBullet), False, rtfText.SelBullet)
        
        .Tools("tbFontName").Text = IIf(IsNull(rtfText.SelFontName), "", rtfText.SelFontName)
        .Tools("tbFontSize").Text = IIf(IsNull(rtfText.SelFontSize), "", rtfText.SelFontSize)
        .Refresh
    End With
    
    tmr.Enabled = False
End Sub

Private Sub tmr_Timer()
    UpdateToolbar
End Sub

Private Sub AutoSaveTimer_Timer()
    Dim i As Integer
    i = i + 1  '计数器加一
    If i = (60 * m_saveinteval) Then
    '约10分钟保存一次,可改变
    i = 0 '计数器清零
    fMainForm.SaveXMLFile frmDocument.Caption
    Screen.MousePointer = vbHourglass
    delay 10000
    Screen.MousePointer = vbDefault
    End If
End Sub