mdidoc.frm

文档编程软件,类似WORD的一个编辑工具.

VERSION 5.00
Object = "{3B7C8863-D78F-101B-B9B5-04021C009402}#1.2#0"; "RICHTX32.OCX"
Begin VB.Form frmMDIDoc 
   Caption         =   "文档"
   ClientHeight    =   3600
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   3930
   Icon            =   "MDIDoc.frx":0000
   LinkTopic       =   "Form1"
   MDIChild        =   -1  'True
   ScaleHeight     =   3600
   ScaleWidth      =   3930
   Begin VB.Timer tmr 
      Enabled         =   0   'False
      Interval        =   200
      Left            =   3600
      Top             =   360
   End
   Begin RichTextLib.RichTextBox rtf 
      Height          =   3495
      Left            =   0
      TabIndex        =   0
      Top             =   0
      Width           =   3855
      _ExtentX        =   6800
      _ExtentY        =   6165
      _Version        =   393217
      Enabled         =   -1  'True
      HideSelection   =   0   'False
      ScrollBars      =   3
      TextRTF         =   $"MDIDoc.frx":0452
   End
End
Attribute VB_Name = "frmMDIDoc"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

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 Enum eTextMode
    TM_PLAINTEXT = 1
    TM_RICHTEXT = 2                '默认行为
    TM_SINGLELEVELUNDO = 4
    TM_MULTILEVELUNDO = 8          '默认行为
    TM_SINGLECODEPAGE = 16
    TM_MULTICODEPAGE = 32          '默认行为
End Enum

Private Const WM_USER = &H400
Private Const WM_PASTE = &H302
Private Const WM_COPY = &H301
Private Const WM_CUT = &H300

Private Const EM_LINEINDEX = &HBB&
Private Const EM_CANUNDO = &HC6
Private Const EM_UNDO = &HC7
Private Const EM_LINEFROMCHAR = &HC9&
Private Const EM_CANPASTE = (WM_USER + 50)
Private Const EM_HIDESELECTION = (WM_USER + 63)
Private Const EM_REQUESTRESIZE = (WM_USER + 65)
Private Const EM_SETUNDOLIMIT = (WM_USER + 82)
Private Const EM_REDO = (WM_USER + 84)
Private Const EM_CANREDO = (WM_USER + 85)
Private Const EM_GETUNDONAME = (WM_USER + 86)
Private Const EM_GETREDONAME = (WM_USER + 87)
Private Const EM_STOPGROUPTYPING = (WM_USER + 88)
Private Const EM_SETTEXTMODE = (WM_USER + 89)
Private Const EM_GETTEXTMODE = (WM_USER + 90)
Private Const EM_AUTOURLDETECT = (WM_USER + 91)

Private m_ab As ActiveBar2LibraryCtl.ActiveBar2

Implements IMDIDocument

Private Sub Form_Resize()
    On Error Resume Next
    rtf.Move 0, 0, ScaleWidth, ScaleHeight
End Sub

Private Function IMDIDocument_CommandHandler(tool As ActiveBar2LibraryCtl.ITool) As Boolean
    
    IMDIDocument_CommandHandler = True
    If tool.Category = "Color" 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 "miFoFont": FormatFont
    Case "miFoFontName": FormatFont
    Case "miFoFontSize": FormatFont
    Case "miFoParagraph": FormatParagraph
    Case "miFoBold": FormatBold
    Case "miFoItalic": FormatItalic
    Case "miFoUnderline": FormatUnderline
    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(rtf.SelBold) Or rtf.SelBold
        .Tools("miFoItalic").Checked = IsNull(rtf.SelItalic) Or rtf.SelItalic
        .Tools("miFoUnderline").Checked = IsNull(rtf.SelUnderline) Or rtf.SelUnderline
        
        .Tools("miECut").Enabled = (rtf.SelLength <> 0)
        .Tools("miECopy").Enabled = (rtf.SelLength <> 0)
        .Tools("miEPaste").Enabled = (SendMessage(rtf.hWnd, EM_CANPASTE, 0, 0) = 1)
        .Tools("miEUndo").Enabled = (SendMessage(rtf.hWnd, EM_CANUNDO, 0, 0) = 1)
        .Tools("miERedo").Enabled = (SendMessage(rtf.hWnd, EM_CANREDO, 0, 0) = 1)
        
        .Tools("miFoLeft").Checked = (rtf.SelAlignment = 0)
        .Tools("miFoCenter").Checked = (rtf.SelAlignment = 2)
        .Tools("miFoRight").Checked = (rtf.SelAlignment = 1)
        
        .Tools("miFoBullets").Checked = IIf(IsNull(rtf.SelBullet), False, rtf.SelBullet)
        
        .Tools("miFoFontName").Text = IIf(IsNull(rtf.SelFontName), "", rtf.SelFontName)
        .Tools("miFoFontSize").Text = IIf(IsNull(rtf.SelFontSize), "", rtf.SelFontSize)
        .Refresh
    End With
    
    tmr.Enabled = False
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
        m_ab.RegisterChildMenu hWnd, "mnuChildDoc"
        m_ab.RecalcLayout
        bRet = True
    End If
    If bNew Then
        rtf.Text = ""
    Else
        '打开文件
        rtf.LoadFile sFile
    End If
    rtf.DataChanged = False
    Caption = sFile
    Me.Show
    
    IMDIDocument_InitDoc = bRet
End Function

Private Function FileSave(Optional sSaveAsName As String) As Boolean
    On Error GoTo ehFileSave '设置捕获错误
    
    If IsMissing(sSaveAsName) Or sSaveAsName = "" Then
        '如果没有指定保存名
        If InStr(Me.Caption, "(无标题)") > 0 Then
            '如果没有以前的保存文件名
            sSaveAsName = "rtfdoc.rtf"
            If Not frmDDWordPadMDI.cdlg.VBGetSaveFileName(sSaveAsName, _
                "RichEdit Document", True, "RTF 格式(*.rtf)|*.rtf", , _
                App.Path, "另存为...", "RTF", Me.hWnd) Then
                FileSave = False
                Exit Function
            End If
        Else
            sSaveAsName = Me.Caption
        End If
    End If
    
    '保存文件
    rtf.SaveFile CStr(sSaveAsName)
    
    '改变窗体标题
    Me.Caption = CStr(sSaveAsName)
    
    '设置返回值为 Ture
    FileSave = True
    rtf.DataChanged = False
    Exit Function
ehFileSave:
    '设置返回值为 false
    FileSave = False
    Exit Function
End Function

Private Sub FileSaveAs()
Dim sSaveAsName As String

    On Error GoTo ehFileSaveAs '设置捕获错误
    
    sSaveAsName = "rtfdoc.rtf"
    If Not frmDDWordPadMDI.cdlg.VBGetSaveFileName(sSaveAsName, _
        "RichEdit Document", True, "RTF 格式(*.rtf)|*.rtf", , _
        App.Path, "另存为", "RTF", Me.hWnd) Then
        Exit Sub
    End If
    
    '保存文件
    rtf.SaveFile CStr(sSaveAsName)
    
    '改变标题以反映文件名
    Me.Caption = CStr(sSaveAsName)
    
    '设置返回值为 Ture
    rtf.DataChanged = False
    
ehFileSaveAs:
    Exit Sub
End Sub

Private Sub FilePrint()
Dim flags As Long
Dim hdc As Long

    On Error GoTo ehFilePrint '设置捕获错误
    With frmDDWordPadMDI.cdlg
        '显示打印对话框
        If .VBPrintDlg(hdc, IIf(rtf.SelLength = 0, eprAll, eprSelection)) = True Then
            '打印所选
            If rtf.SelLength <> 0 Then
                rtf.SelPrint hdc
            Else
                '打印全部
                rtf.SelLength = 0
                rtf.SelPrint hdc
            End If
        End If
    End With
ehFilePrint: '取消进程
    Exit Sub
End Sub

Private Sub FilePrintPreview()
    Dim fPreview As New frmPreview
    Dim doc As IMDIDocument
    Set doc = fPreview
    doc.InitDoc m_ab, Me.Caption, False
    fPreview.PrintPreview rtf, 1440, 1440, 1440, 1440, vbPRORLandscape
End Sub

Private Sub FilePageSetup()
    frmPageSetup.Show vbModal
End Sub

Private Sub EditRedo()
    SendMessage rtf.hWnd, EM_REDO, 0, 0
End Sub

Private Sub EditUndo()
Dim hr As Long
    hr = SendMessage(rtf.hWnd, EM_GETUNDONAME, 0&, 0&)
    ' Debug.Print hr, Choose(hr + 1, "Unknown", "Typing", "Delete", "Drag Drop", "Cut", "Paste")
    SendMessage rtf.hWnd, EM_UNDO, 0, 0
End Sub

Private Sub EditCut()
    SendMessage rtf.hWnd, WM_CUT, 0, 0
'    rtf.SetFocus
End Sub

Private Sub EditCopy()
    SendMessage rtf.hWnd, WM_COPY, 0, 0
End Sub

Private Sub EditPaste()
    SendMessage rtf.hWnd, WM_PASTE, 0, 0
End Sub

Private Sub EditClear()
    rtf.SelText = ""
End Sub

Private Sub EditSelectAll()
    rtf.SelStart = 0
    rtf.SelLength = Len(rtf.Text)
End Sub

Private Sub EditFind(strSearch As String)
    frmFindForm.txtFind = strSearch '设置查找文本
    frmFindForm.Show
End Sub

Private Sub EditFindNext()
    frmFindForm.cboSearch.ListIndex = 2
    If frmFindForm.txtFind <> "" Then
        frmFindForm.cmdFindNext.Value = True
    End If
    frmFindForm.Show
End Sub

Private Sub EditReplace(strSearch As String)
    With frmFindForm
        .txtFind = strSearch '设置查找文本
        .txtReplace.Enabled = True '使能够替换
        .lblReplace.Enabled = True '使能够替换
        .Show vbModal '显示为有模式的
    End With
End Sub

Private Sub InsertDate()
    rtf.SelText = Format(Now, "Long Date")
End Sub

Private Sub InsertTime()
    rtf.SelText = Format$(Now, "Hh:Nn:Ss")
End Sub

Private Sub InsertPicture()
'感谢 "Joachim Thiele" www.N-H-P.de
On Error Resume Next
Dim sFile As String

    If frmDDWordPadMDI.cdlg.VBGetOpenFileName(sFile, "图片文件", True, False, False, True, "图片文件(*.BMP;*.GIF;*.JPG)|*.BMP;*.GIF;*.JPG", , App.Path, "插入图片", , Me.hWnd) Then
        Clipboard.Clear
        DoEvents
        Clipboard.SetData LoadPicture(sFile)
        If Clipboard.GetFormat(vbCFBitmap) = True Then '位图
            rtf.SetFocus
            EditPaste
        Else
            MsgBox "没有选择图片！"
        End If
    End If
    
End Sub

Private Sub FormatFont()
Dim fnt As New StdFont
Dim clr As Long

    On Error Resume Next
    With rtf
        fnt.Name = .SelFontName
        fnt.Strikethrough = .SelStrikeThru
        fnt.Bold = .SelBold
        fnt.Italic = .SelItalic
        fnt.Underline = .SelUnderline
        fnt.Size = .SelFontSize
        clr = .SelColor
        If frmDDWordPadMDI.cdlg.VBChooseFont(fnt, , Me.hWnd, clr, 5, 72, CF_ScreenFonts Or CF_EFFECTS) Then
                .SelFontName = fnt.Name
                .SelBold = fnt.Bold
                .SelColor = clr
                .SelItalic = fnt.Italic
                .SelUnderline = fnt.Underline
                .SelFontSize = fnt.Size
                .SelStrikeThru = fnt.Strikethrough
        End If
    End With
    Set fnt = Nothing
End Sub


Private Sub FormatParagraph()
    frmParagraph.Show vbModal
'    rtf.SetFocus
End Sub

Private Sub FormatBold()
    With rtf
        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 rtf
        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 rtf
        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)
    Dim lClr As Long
    lClr = CLng(tool.TagVariant)
    rtf.SelColor = lClr
End Sub

Private Sub FormatAlign(intIndex As Integer)
    Select Case intIndex
        Case 0 '左对齐
            '设置对齐方式
            rtf.SelAlignment = rtfLeft
        Case 1 '居中
            '设置对齐方式
            rtf.SelAlignment = rtfCenter
        Case 2 '右对齐
            '设置图片
            '设置对齐方式
            rtf.SelAlignment = rtfRight
    End Select
End Sub

Private Sub FormatBullets()
    With rtf
        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 FormatTabs()
    frmTabs.Show vbModal
End Sub

Private Sub rtf_GotFocus()
    Set frmDDWordPadMDI.currentCtl = rtf
End Sub

Private Sub rtf_LostFocus()
    Set frmDDWordPadMDI.currentCtl = Nothing
End Sub

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

Private Sub tmr_Timer()
    UpdateToolbar
End Sub