fileedit.frm

这个源代码可以实现基本的文本编辑功能

      Begin VB.Menu mnuExit 
         Caption         =   "退出（&X）"
      End
   End
   Begin VB.Menu mnuEdit 
      Caption         =   "编辑（&E）"
      Begin VB.Menu mnuEditCut 
         Caption         =   "剪切（&T）"
         Shortcut        =   ^X
      End
      Begin VB.Menu mnuEditCopy 
         Caption         =   "复制（&C）"
         Shortcut        =   ^C
      End
      Begin VB.Menu mnuEditPaste 
         Caption         =   "粘贴（&P）"
         Shortcut        =   ^V
      End
   End
   Begin VB.Menu mnuHelp 
      Caption         =   "帮助（&H）"
      Begin VB.Menu about 
         Caption         =   "关于（&A）..."
      End
   End
   Begin VB.Menu rightmenu 
      Caption         =   "右键菜单"
      Visible         =   0   'False
      Begin VB.Menu cut 
         Caption         =   "剪切"
      End
      Begin VB.Menu copy 
         Caption         =   "复制"
      End
      Begin VB.Menu paste 
         Caption         =   "粘贴"
      End
      Begin VB.Menu line 
         Caption         =   "-"
      End
      Begin VB.Menu font 
         Caption         =   "字体"
      End
   End
End
Attribute VB_Name = "frmDocument"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Public boolDirty As Boolean

Private Sub copy_Click()
    mnuEditCopy_Click
End Sub

Private Sub cut_Click()
    mnuEditCut_Click
End Sub

Private Sub font_Click()
dlgCommonDialog.Flags = &H400 Or &H200 Or &H3 Or &H100
dlgCommonDialog.ShowFont
With rtfText
.SelFontName = dlgCommonDialog.FontName
.SelFontSize = dlgCommonDialog.FontSize
.SelColor = dlgCommonDialog.Color
.SelBold = dlgCommonDialog.FontBold
.SelItalic = dlgCommonDialog.FontItalic
.SelStrikeThru = dlgCommonDialog.FontStrikethru
.SelUnderline = dlgCommonDialog.FontUnderline
End With

End Sub

Private Sub form_activate()
    boolDirty = False
End Sub

Private Sub about_Click()
    frmAbout.Show
End Sub

Private Sub Combo1_Click()
    rtfText.SelFontName = Combo1.Text
End Sub

Private Sub Combo2_Click()
    rtfText.SelFontSize = Val(Combo2.Text)
End Sub

Private Sub Form_Load()
    Dim i
    For i = 1 To Screen.FontCount
        Combo1.AddItem Screen.Fonts(i)
    Next
    Combo1.ListIndex = 61
    For i = 8 To 72 Step 2
      Combo2.AddItem Str(i)
    Next
    Combo2.ListIndex = 2
    
    Toolbar1.Buttons(4).Enabled = False
    Toolbar1.Buttons(5).Enabled = False
    Toolbar1.Buttons(6).Enabled = False
    
    cut.Enabled = False
    copy.Enabled = False
    Clipboard.Clear
    
    mnuEditPaste.Enabled = False
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)
    Dim temp
    If Me.boolDirty = True Then
        temp = MsgBox(Me.Caption & "已经修改，是否保存？", vbYesNoCancel + vbQuestion, "提示")
        If temp = vbYes Then
            mnuFileSave_Click
        ElseIf temp = vbNo Then
            Unload Me
        Else
            Cancel = 1
        End If
    End If
End Sub

Private Sub Form_Resize()
    Me.rtfText.Width = Me.ScaleWidth
    Me.rtfText.Height = Me.ScaleHeight - StatusBar1.Height - Toolbar1.Height - Toolbar2.Height
End Sub

Private Sub mnuEdit_Click()
    If rtfText.SelText <> "" Then
        mnuEditCut.Enabled = True
        mnuEditCopy.Enabled = True
    Else
        mnuEditCut.Enabled = False
        mnuEditCopy.Enabled = False
    End If
End Sub

Private Sub mnuEditCopy_Click()
    On Error Resume Next
    Clipboard.Clear
    If rtfText.SelText <> "" Then
    End If
    Clipboard.SetText Me.rtfText.SelRTF
    If Clipboard.GetText = "" Then
        Toolbar1.Buttons(6).Enabled = False
        mnuEditPaste.Enabled = False
    Else
        Toolbar1.Buttons(6).Enabled = True
        mnuEditPaste.Enabled = True
   
    End If
End Sub

Private Sub mnuEditCut_Click()
    On Error Resume Next
    Clipboard.Clear
    Clipboard.SetText Me.rtfText.SelRTF
    Me.rtfText.SelRTF = vbNullString
    If Clipboard.GetText = "" Then
        Toolbar1.Buttons(6).Enabled = False
        mnuEditPaste.Enabled = False

    Else
        Toolbar1.Buttons(6).Enabled = True
        mnuEditPaste.Enabled = True
    
    End If
End Sub

Private Sub mnuEditPaste_Click()
    On Error Resume Next
    Me.rtfText.SelRTF = Clipboard.GetText
End Sub

Private Sub mnuExit_Click()
    Dim temp
    If Me.boolDirty = False Then
        temp = MsgBox("文档已经修改，是否保存？", vbYesNoCancel + vbQuestion, "提示")
        If temp = vbYes Then
            mnuFileSave_Click
        ElseIf temp = vbNo Then
            End
        Else
            Exit Sub
        End If
    End If
End Sub

Private Sub mnuFileNew_Click()
    LoadNewDoc
End Sub

Private Sub mnuFileOpen_Click()
    Dim sFile As String
    With dlgCommonDialog
        .DialogTitle = "打开"
        .InitDir = "C:\Documents and Settings"
        .CancelError = False
        .Filter = "rtf文件(*.rtf)|*.rtf|纯文本文件(*.txt)|*.txt"
        .ShowOpen
        If Len(.FileName) = 0 Then
            Exit Sub
        End If
        
        sFile = .FileName
    End With
    LoadNewDoc
    Me.rtfText.LoadFile sFile
    Me.Caption = sFile
End Sub

Private Sub mnuFileSave_Click()
    Dim sFile As String
    Dim ss As String
    ss = Me.Caption
    If Left$(ss, 2) = "文档" Then
        sFile = strFileName
        Select Case dlgCommonDialog.FilterIndex
            Case 1
                dlgCommonDialog.DefaultExt = "rtf"
            Case 2
                dlgCommonDialog.DefaultExt = "txt"
        End Select
        If sFile <> "" Then
            Me.rtfText.SaveFile sFile
            Me.Caption = sFile
        End If
    Else
        sFile = Me.Caption
        Me.rtfText.SaveFile sFile
    End If
    If sFile <> "" Then
        Me.boolDirty = False
    End If
        
End Sub

Public Function strFileName() As String
    On Error Resume Next
    With dlgCommonDialog
        .CancelError = True
        .DialogTitle = "保存"
        .Filter = "rtf文件（*.rtf）|*.rtf|纯文本文件（*.txt）|*.txt"
        .ShowSave
        If Err.Number = 32755 Then
           Exit Function
        End If
        If Len(.FileName) = 0 Then
            Exit Function
        End If
        strFileName = .FileName
    End With
End Function

Private Sub paste_Click()
    mnuEditPaste_Click
End Sub

Private Sub rtfText_Change()
    boolDirty = True
End Sub

Private Sub rtfText_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single)
    If Button = 2 Then
        PopupMenu rightmenu
        If rtfText.SelText = "" Then
            cut.Enabled = False
            copy.Enabled = False
        Else
            cut.Enabled = True
            copy.Enabled = True
        End If
    End If
End Sub

Private Sub rtfText_MouseMove(Button As Integer, Shift As Integer, x As Single, y As Single)
    StatusBar1.Panels(2).Text = x & "行，" & y & "列"
End Sub

Private Sub rtfText_SelChange()
    If rtfText.SelLength = 0 Then
        Toolbar1.Buttons(4).Enabled = False
        Toolbar1.Buttons(5).Enabled = False
    Else
        Toolbar1.Buttons(4).Enabled = True
        Toolbar1.Buttons(5).Enabled = True
    End If
    
    Select Case rtfText.SelBold
        Case 0
            Toolbar2.Buttons(4).Value = tbrUnpressed
            Toolbar2.Buttons(4).MixedState = False
        Case -1
            Toolbar2.Buttons(4).Value = tbrPressed
            Toolbar2.Buttons(4).MixedState = False
        Case Else
            Toolbar2.Buttons(4).MixedState = True
    End Select
    
    Select Case rtfText.SelItalic
        Case 0
            Toolbar2.Buttons("italic").Value = tbrUnpressed
            Toolbar2.Buttons("italic").MixedState = False
        Case -1
            Toolbar2.Buttons("italic").Value = tbrPressed
            Toolbar2.Buttons("italic").MixedState = False
        Case Else
            Toolbar2.Buttons("italic").MixedState = True
    End Select
    Select Case rtfText.SelUnderline
        Case 0
            Toolbar2.Buttons(6).Value = tbrUnpressed
            Toolbar2.Buttons(6).MixedState = False
        Case -1
            Toolbar2.Buttons(6).Value = tbrPressed
            Toolbar2.Buttons(6).MixedState = False
        Case Else
            Toolbar2.Buttons(6).MixedState = True
    End Select
    Select Case rtfText.SelStrikeThru
        Case 0
            Toolbar2.Buttons(7).Value = tbrUnpressed
            Toolbar2.Buttons(7).MixedState = False
        Case -1
            Toolbar2.Buttons(7).Value = tbrPressed
            Toolbar2.Buttons(7).MixedState = False
        Case Else
            Toolbar2.Buttons(7).MixedState = True
    End Select
    
    If Not IsNull(rtfText.SelFontSize) Then
        Combo2.Text = rtfText.SelFontSize
    End If
    
    If Not IsNull(rtfText.SelFontName) Then
        Combo1.Text = rtfText.SelFontName
    End If
    
    Select Case rtfText.SelAlignment
        Case rtfLeft
            Toolbar2.Buttons("left").Value = tbrPressed
            Toolbar2.Buttons("left").MixedState = False
        Case rtfCenter            'right
            Toolbar2.Buttons("center").Value = tbrPressed
            Toolbar2.Buttons("center").MixedState = False

        Case rtfRight             'Center
              Toolbar2.Buttons("right").Value = tbrPressed
             Toolbar2.Buttons("right").MixedState = False
        
        Case Else
            Toolbar2.Buttons("left").Value = tbrUnpressed
            Toolbar2.Buttons("right").Value = tbrUnpressed
            Toolbar2.Buttons("center").Value = tbrUnpressed
    End Select
    

End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "new"
            LoadNewDoc
        Case "open"
            mnuFileOpen_Click
        Case "save"
            mnuFileSave_Click
        Case "cut"
            mnuEditCut_Click
        Case "copy"
            mnuEditCopy_Click
        Case "paste"
            mnuEditPaste_Click
        Case "help"
            about_Click
    End Select
End Sub

Private Sub Toolbar2_ButtonClick(ByVal Button As MSComctlLib.Button)
    On Error Resume Next
    Select Case Button.Key
        Case "bond"
            If rtfText.SelBold = False Then
                rtfText.SelBold = True
            Else
                rtfText.SelBold = False
            End If
        Case "italic"
            If rtfText.SelItalic = False Then
                rtfText.SelItalic = True
            Else
                rtfText.SelItalic = False
            End If
        Case "underline"
            If rtfText.SelUnderline = False Then
                rtfText.SelUnderline = True
            Else
                rtfText.SelUnderline = False
            End If
        Case "delline"
            If rtfText.SelStrikeThru = False Then
                rtfText.SelStrikeThru = True
            Else
                rtfText.SelStrikeThru = False
            End If
        Case "fontcolor"
            dlgCommonDialog.Action = 3
            rtfText.SelColor = dlgCommonDialog.Color
        Case "left"
            rtfText.SelAlignment = 0
        Case "center"
            rtfText.SelAlignment = 2
        Case "right"
            rtfText.SelAlignment = 1
            
            
    End Select
End Sub