ymodule2.bas

文本编辑器。可以通过此列制作出自己的实用编辑器。

Attribute VB_Name = "Module2"
Option Explicit
Public Function fontname()
   fMainForm.ActiveForm.rtfText.SelFontName = fMainForm.cmFontName.Text
   fMainForm.ActiveForm.rtfText.SetFocus
End Function
Public Function FontSize()
   fMainForm.ActiveForm.rtfText.SelFontSize = fMainForm.cmFontSize.Text
   fMainForm.ActiveForm.rtfText.SetFocus
End Function
Public Function Paste_Click()
    On Error Resume Next
    Screen.ActiveForm.rtfText.SelRTF = Clipboard.GetText

End Function

Public Function Copy_Click()
    On Error Resume Next
    Clipboard.SetText Screen.ActiveForm.rtfText.SelRTF
    
    
End Function
Public Function Cut_Click()
On Error Resume Next
   Clipboard.SetText Screen.ActiveForm.rtfText.SelRTF
   Screen.ActiveForm.rtfText.SelRTF = vbNullString
   
End Function

Public Function font_Click()
   On Error GoTo errhandler
     With fMainForm.dlgCommonDialog
     
        .DialogTitle = "字体"
        .CancelError = True
        .Flags = cdlCFEffects Or cdlCFBoth
        .ShowFont
     End With
    Screen.ActiveForm.rtfText.SelFontName = fMainForm.dlgCommonDialog.fontname
    Screen.ActiveForm.rtfText.SelFontSize = fMainForm.dlgCommonDialog.FontSize
    Screen.ActiveForm.rtfText.SelBold = fMainForm.dlgCommonDialog.FontBold
    Screen.ActiveForm.rtfText.SelItalic = fMainForm.dlgCommonDialog.FontItalic
    Screen.ActiveForm.rtfText.SelUnderline = fMainForm.dlgCommonDialog.FontUnderline
    Screen.ActiveForm.rtfText.SelStrikeThru = fMainForm.dlgCommonDialog.FontStrikethru
    Screen.ActiveForm.rtfText.SelColor = fMainForm.dlgCommonDialog.color
errhandler:
     Exit Function
End Function
Public Function LoadNewDoc()
   

    Static lDocumentCount As Long
   
    lDocumentCount = lDocumentCount + 1
    Set frmD = New frmDocument
    frmD.Caption = "Document " & lDocumentCount
   
    frmD.Show
    saveflag(lDocumentCount) = False
    TextChanged(lDocumentCount) = False
End Function
Public Function ArrangeIcons_Click()
    fMainForm.Arrange vbArrangeIcons
End Function

Public Function TileVertical_Click()
   fMainForm.Arrange vbTileVertical
End Function

Public Function mnuWindowTileHorizontal_Click()
    fMainForm.Arrange vbTileHorizontal
End Function

Public Function mnuWindowCascade_Click()
    fMainForm.Arrange vbCascade
End Function
Public Function Open_Click()
    Dim sFile As String
    Dim i As Integer
    If Screen.ActiveForm.rtfText.Text <> vbNullString Then LoadNewDoc
     i = Mid(Screen.ActiveForm.Caption, 10, 1)
            With fMainForm.dlgCommonDialog
                .DialogTitle = "打开"
                .CancelError = False
                .Flags = cdlOFNHideReadOnly
                .Filter = "所有文件 (*.*)|*.*|文本文件(*.txt)|*.txt|WORD文档(*.doc)|*.doc"
                .ShowOpen
                 If FileLen(.FileName) > 65000 Then
                         MsgBox "文件太大，无法打开。", vbOKOnly, "文件打开"
                   Exit Sub
                 End If
                If Len(.FileName) = 0 Then
                   Exit Function
                   Unload Screen.ActiveForm
                End If
                sFile = .FileName
            End With
           
              Screen.ActiveForm.rtfText.LoadFile sFile
              Screen.ActiveForm.Caption = "Document " & i & "----" & sFile
            
        
End Function
Public Function Save_Click()
Dim sFile As String
Dim i As Integer

 If InStr(Screen.ActiveForm.Caption, "Document") = 1 Then

  If TextChanged(Mid(fMainForm.ActiveForm.Caption, 10, 1)) Then
   i = Mid(Screen.ActiveForm.Caption, 10, 1)
    With fMainForm.dlgCommonDialog
        .DialogTitle = "保存"
        .CancelError = False
        .Flags = cdlOFNOverwritePrompt
        If Len(Screen.ActiveForm.Caption) > 10 Then
          .FileName = Mid(Screen.ActiveForm.Caption, 15)
        Else
        .FileName = Screen.ActiveForm.Caption
        
        End If
        
        .Filter = "所有文件 (*.*)|*.*|文本文件(*.txt)|*.txt|WORD文档(*.doc)|*.doc"
        If saveflag(Mid(Screen.ActiveForm.Caption, 10, 1)) = False Then
         .ShowSave
        
        End If
        If Len(.FileName) = 0 Then
            Exit Function
        End If
        sFile = .FileName
       
    End With
      If saveflag(Mid(Screen.ActiveForm.Caption, 10, 1)) = False Then
          Screen.ActiveForm.rtfText.SaveFile sFile
          saveflag(Mid(Screen.ActiveForm.Caption, 10, 1)) = True
          Screen.ActiveForm.Caption = "Document " & i & "----" & sFile
          TextChanged(Mid(fMainForm.ActiveForm.Caption, 10, 1)) = False
     End If
  Else
    Exit Function
  End If
 Else
   MsgBox "不存在要保存的文件", vbOKOnly, "警告！"
 End If
End Function

Public Function Delete_Click()
 On Error Resume Next
   
   Screen.ActiveForm.rtfText.SelRTF = vbNullString

End Function
Public Function ViewToolbar_Click()
    
    fMainForm.mnuViewToolbar.Checked = Not fMainForm.mnuViewToolbar.Checked
    frmD.mnuViewToolbar.Checked = fMainForm.mnuViewToolbar.Checked
    fMainForm.tbToolBar.Visible = fMainForm.mnuViewToolbar.Checked

End Function
Public Function ViewStatusBar_Click()
    
    fMainForm.mnuViewStatusBar.Checked = Not fMainForm.mnuViewStatusBar.Checked
    frmD.mnuViewStatusBar.Checked = fMainForm.mnuViewStatusBar.Checked
    fMainForm.sbStatusBar.Visible = fMainForm.mnuViewStatusBar.Checked

End Function
Public Function findnext()
Dim pos As Integer
Dim start As Integer
Dim intOffset As Integer

    If (gCurPos = fMainForm.ActiveForm.ActiveControl.SelStart) _
        And fMainForm.ActiveForm.rtfText.SelText = FindString _
         Then
        intOffset = 1
    Else
        intOffset = 0
    End If
    
    start = fMainForm.ActiveForm.ActiveControl.SelStart + intOffset
     

  If Direction Then
     pos = InStr(start + 1, FoundString, FindString)
  Else
   For pos = start - 1 To 0 Step -1
     If pos = 0 Then Exit For
     If Mid(FoundString, pos, Len(FindString)) = FindString Then Exit For
   Next
  End If
   If pos Then
     Finding = True
     fMainForm.ActiveForm.rtfText.SelStart = pos - 1
     fMainForm.ActiveForm.rtfText.SelLength = Len(FindString)
     gCurPos = pos - 1
     
   Else
     Finding = False
     gCurPos = 0
     If ReplaceFlag = False Then
     MsgBox "找不到" & Chr(34) & FindString & Chr(34), vbOKOnly, App.Title
     End If
    End If
   
   
  
End Function
Public Function Replace()
    findnext
  If Finding Then
     fMainForm.ActiveForm.rtfText.SelText = EditFind.Combo2.Text
     FoundString = fMainForm.ActiveForm.rtfText.Text
  End If
End Function
Public Function SpellCheck(IncorrectText As String) As String
   On Error GoTo errHdl
    Dim mWord As Object
    
    Screen.MousePointer = vbHourglass
    Set mWord = CreateObject("Word.Application")
    mWord.Visible = False

    mWord.Documents.Add
    mWord.Selection.Text = fMainForm.ActiveForm.rtfText.Text
    mWord.ActiveDocument.CheckSpelling
    fMainForm.ActiveForm.rtfText.Text = mWord.Selection.Text
    mWord.Quit
    Set mWord = Nothing
    Screen.MousePointer = vbDefault
    Exit Function
errHdl:
    MsgBox "请确信你安装的Word语法检查器(mssp232.dll)", vbCritical, "提示"
    Screen.MousePointer = vbDefault
End Function
Public Function Paragraph_Click()
  With fMainForm.ActiveForm.rtfText
    
    .SelStart = 0
    .SelLength = Len(fMainForm.ActiveForm.rtfText)
    .SelIndent = CInt(paragraph.Text1(0).Text) / 10
    .SelRightIndent = CInt(paragraph.Text1(1).Text) / 10
    .SelHangingIndent = -CInt(paragraph.Text1(2).Text) / 10
    
  End With
  
End Function
Public Function fontcolor()


  On Error GoTo errhandler
     With fMainForm.dlgCommonDialog
        .DialogTitle = "字体颜色"
        .CancelError = True
        .Flags = cdlCCFullOpen
        .ShowColor
     End With
     
     fMainForm.ActiveForm.rtfText.SelColor = fMainForm.dlgCommonDialog.color
errhandler:
     Exit Function
End Function
Public Function FontSize_Change()
    On Error GoTo errhandler
   With fMainForm.dlgCommonDialog
       .Flags = cdlCFEffects Or cdlCFBoth
       .CancelError = True
       .FontSize = fMainForm.cmFontSize.Text
   End With
   fMainForm.ActiveForm.rtfText.SelStart = Startsel
   fMainForm.ActiveForm.rtfText.SelLength = Length

   fMainForm.ActiveForm.rtfText.SelFontSize = fMainForm.dlgCommonDialog.FontSize
errhandler:
     Exit Function
End Function
Public Function fontname_change()
On Error GoTo errhandler
   With fMainForm.dlgCommonDialog
       .Flags = cdlCFEffects Or cdlCFBoth
       .CancelError = True
       .fontname = fMainForm.cmFontName.Text
   End With
   fMainForm.ActiveForm.rtfText.SetFocus
   fMainForm.ActiveForm.rtfText.SelStart = Startsel
   fMainForm.ActiveForm.rtfText.SelLength = Length
   fMainForm.ActiveForm.rtfText.SelFontName = fMainForm.dlgCommonDialog.fontname
errhandler:
     Exit Function
End Function
Public Function undo_click()
Dim ls As String
  ls = SendMessage(fMainForm.ActiveForm.rtfText.hwnd, &H304, 0, 0)

   fMainForm.ActiveForm.rtfText.SetFocus
  
   If undo Then
    
     fMainForm.ActiveForm.mnuEditUndo.Caption = "恢复"
     
   Else
     
      fMainForm.ActiveForm.mnuEditUndo.Caption = "撤销"
   End If
    undo = Not (undo)
 End Function