text.frm

两个VB播放器 两个VB播放器 两个VB播放器 两个VB播放器

     x = MsgBox("文档已经改变，是否保存改变", vbYesNoCancel + vbExclamation, "提示")
      If x = vbYes Then
           ric.SaveFile (Form1.CommonDialog2.FileName), rtfText
           Unload Form3
      ElseIf x = vbNo Then
           Unload Form3
      ElseIf x = vbCancel Then
           DoEvents
      End If
   End If
 Else
   DoEvents
 End If
   Unload Me
End Sub

Private Sub meuFind_Click()
  frmFind.Show
End Sub

Private Sub meuFirst_Click()
  meuFirst.Checked = True
  meuTwo.Checked = False
  meuThree.Checked = False
  ric.BackColor = &HC0FFC0
  ric.SelStart = 0                                 '//光标在最前
  ric.SelLength = Len(ric.Text)                    '//选中所有文本
  ric.SelIndent = 1000                             '//文本距左边为1000
  ric.SelColor = &H0&
  ric.SelFontName = "Fixedsys"
  ric.SelLength = 0                                '//选中文本长为0
End Sub

Private Sub meuFont_Click()
  On Error Resume Next
   With CommonDialog2
     .Flags = cdlCFBoth + cdlCFEffects                 '//字体类型
     .ShowFont
     .DialogTitle = "设置字体"
    If Err.Number = cdlCancel Then Exit Sub
   End With
  ric.SelStart = 0
  ric.SelLength = Len(ric.Text)
  ric.SelFontName = CommonDialog2.FontName
  ric.SelBold = CommonDialog2.FontBold
  ric.SelItalic = CommonDialog2.FontItalic
  ric.SelFontSize = CommonDialog2.FontSize
  ric.SelColor = CommonDialog2.Color
  ric.SelStrikeThru = CommonDialog2.FontStrikethru
  ric.SelUnderline = CommonDialog2.FontUnderline
  'Ric.RightMargin = 100
  ric.SelLength = 0
End Sub

Private Sub meuHelpP_Click()
 Dialog1.Show
 Dialog1.RichTextBox1.Text = "            欢迎使用红叶简易文本查看器 " & Chr(10) + Chr(13) & _
    "   它具有比记事本更好的功能也更好用，它只是作为Super Player 9.0 的附带的一个工具。用于查看文本文件和rtf文本非常适用.用法非常简单。" & Chr(13) + Chr(10)

End Sub

Private Sub meuLeft_Click()
  ric.SelAlignment = 0
End Sub

Private Sub meulishi_Click(index As Integer)
  On Error Resume Next
   ric.FileName = meulishi(index).Caption                        '//打开以前使用过的文件
   ric.SelStart = 0
   ric.SelLength = Len(ric.Text)
   ric.SelIndent = 1000
   ric.SelLength = 0
End Sub

Private Sub meuLook_Click()
  Form4.Show
End Sub

Private Sub meuMiddle_Click()
  ric.SelAlignment = 2
End Sub

Private Sub meuNew_Click()
   If ric.Text <> "" Then
        x = MsgBox("编辑器文字已改变，是否保存更改。", vbYesNoCancel + vbExclamation, "警告")
     If x = vbYes Then
        meuTXT_Click
        ric.Text = ""
     ElseIf x = vbNo Then
        ric.Text = ""
     ElseIf x = vbCancel Then
        DoEvents
     End If
   ElseIf ric.Text = "" Then
     DoEvents
   End If
   If meuTwo.Checked = True Then
        ric.SelColor = &HFF00&
   End If
End Sub

Private Sub meuNo_Click()
   'meuNo.Checked = Not meuNo.Checked
       meuNo.Checked = True
   If meuNo.Checked = True Then
       meuEdite.Checked = False
       mnuCut.Enabled = False
       mnuReDo.Enabled = False
       mnuUndo.Enabled = False
       mnuPaste.Enabled = False
       mnuDelete.Enabled = False
       mnuCopy.Enabled = False
       'meuFirst.Enabled = True
       'meuTwo.Enabled = True
       'meuThree.Enabled = True
       meuNew.Enabled = False
       meuLeft.Enabled = False
       meuRight.Enabled = False
       meuMiddle.Enabled = False
       meuTXT.Enabled = False
       meuRTF.Enabled = False
       meuEditFont.Enabled = False
     ric.Locked = True
     meuSave.Enabled = False
     meuSaveNow.Enabled = False
     ric.MousePointer = 1
   End If
End Sub

Private Sub meuOpen_Click()
  On Error Resume Next
  Dim i As Integer
  i = 0
   With CommonDialog2
    .DialogTitle = "打开文件"                          '//打开对话框
    .FileName = ""
    .InitDir = "C:\My Documents"
    .Filter = "文本文件(*.txt;*.rtf)|*.txt;*.rtf|网页(*.htm)|*.htm|程序文件(*.C;*.CPP;*.h;*.dsw;*.dsp;*.plg;*.frm;*.vbp)|*.C;*.CPP;*.h;*.dsw;*.dsp;*.plg;*.frm;*.vbp|其他(*.ini;*.log;*.bat)|*.ini;*.log;*.bat|列表文件(*.m3u)|*.m3u|所有文件(*.*)|*.*|"
    .ShowOpen
  If Err.Number = cdlCancel Then Exit Sub                    '//取消退出
    End With
     ric.LoadFile (CommonDialog2.FileName)
     ric.SelStart = 0                                           '//格式化打开文件
     ric.SelLength = Len(ric.Text)
     If meuTwo.Checked = True Then
        ric.SelColor = &HFF00&
     End If
     
     ric.SelIndent = 1000
     ric.SelLength = 0
   Open App.Path & "\temp\histroy" For Input As #1
      Do While Not EOF(1)
        i = i + 1
        Line Input #1, nextline
        If nextline = "" Then Exit Do
      Loop
   Close #1
 If i > 5 Then
    Kill App.Path & "\histroy"
 End If
 If CommonDialog2.FileName = "" Then
   meulishi(1).Caption = Form1.CommonDialog2.FileName           '//保存打开过的文件到记事本
   Open App.Path & "\temp\histroy" For Append As #1
      Print #1, Form1.CommonDialog2.FileName
   Close #1
 Else
   Open App.Path & "\temp\histroy" For Append As #1
      Print #1, CommonDialog2.FileName
   Close #1
 End If
End Sub

Private Sub meuPrint_Click()
 On Error Resume Next
   CommonDialog2.Flags = cdlPDReturnDC + cdlPDNoPageNums             '//打印所选文件
   If ric.SelLength = 0 Then
      CommonDialog2.Flags = CommonDialog2.Flags + cdlPDAllPages
   Else
      CommonDialog2.Flags = CommonDialog2.Flags + cdlPDSelection
   End If
   CommonDialog2.ShowPrinter
   If Err.Number = cdlCancel Then Exit Sub
   ric.SelPrint CommonDialog2.hDC

End Sub

Private Sub meuPrintAll_Click()

  On Error Resume Next
   CommonDialog2.Flags = cdlPDReturnDC + cdlPDNoPageNums            '//打印全文
   If ric.SelLength = 0 Then
      CommonDialog2.Flags = CommonDialog2.Flags + cdlPDAllPages
   Else
      CommonDialog2.Flags = CommonDialog2.Flags + cdlPDSelection
   End If
    CommonDialog2.ShowPrinter
  If Err.Number = cdlCancel Then Exit Sub
 For i = 1 To CommonDialog2.Copies
   Printer.Print ric.Text
 Next i
 Printer.EndDoc

End Sub

Private Sub meuRight_Click()
 ric.SelAlignment = 1
End Sub

Private Sub meuRTF_Click()
   On Error Resume Next
   Dim x
    With CommonDialog2
      If .FileName = "" Then                      '//保存为RTF格式
       .FileName = "新建RTF文档"
      End If
       .FileName = "新建RTF文档"
       .DialogTitle = "另存为"
       .Filter = "RTF(*.rtf)|*.rtf|All Files(*.*)|*.*|"
       .ShowSave
     If Err.Number = cdlCancel Then Exit Sub
    End With
   ric.SaveFile (CommonDialog2.FileName)
End Sub

Private Sub meuSaveNow_Click()
  On Error Resume Next
   If CommonDialog2.FileName = "" Then
      meuTXT_Click
   Else
      ric.SaveFile CommonDialog2.FileName, rtfText
   End If
End Sub

Private Sub meuSuo_Click()
  On Error Resume Next
  ric.SelIndent = ric.SelIndent + 200
End Sub

Private Sub meuThree_Click()
  meuFirst.Checked = False
  meuTwo.Checked = False
  meuThree.Checked = True
  ric.SelStart = 0
  ric.SelLength = Len(ric.Text)
  ric.SelFontName = "Fixedsys"
  ric.SelColor = &H0&
  ric.SelIndent = 1000
  ric.BackColor = &H80000009
  ric.SelLength = 0
End Sub

Private Sub meuTimeDate_Click()
  ric.SelText = Now                         '//插入时间
End Sub

Private Sub meuTwo_Click()
  meuFirst.Checked = False
  meuTwo.Checked = True
  meuThree.Checked = False
  ric.SelStart = 0
  ric.SelLength = Len(ric.Text)
  ric.SelFontName = "Fixedsys"
  ric.SelColor = &HFF00&
  ric.SelIndent = 1000
  ric.BackColor = &H0&
  ric.SelLength = 0
End Sub

Private Sub meuTXT_Click()
   On Error Resume Next
   Dim x
    With CommonDialog2
      If .FileName = "" Then
       .FileName = "新建文本文档"                 '//保存为通常文本
      End If
       .FileName = .FileName
       .DialogTitle = "另存为"
       .Filter = "TXT(*.txt)|*.txt|All Files(*.*)|*.*|"
       .ShowSave
     If Err.Number = cdlCancel Then Exit Sub
    End With
   ric.SaveFile (CommonDialog2.FileName), rtfText
End Sub

Private Sub meuXiao_Click()
  If ric.SelIndent >= 200 Then
       ric.SelIndent = ric.SelIndent - 200
  End If
End Sub

Private Sub mnuCopy_Click()                          '//剪切，复制，删除，重做，撤消代码
    Clipboard.SetText ric.SelText, 1
End Sub

Private Sub mnuCut_Click()
    Clipboard.SetText ric.SelText, 1
    ric.SelText = ""
End Sub

Private Sub mnuDelete_Click()
    ric.SelText = ""
End Sub

Private Sub mnuPaste_Click()
    ric.SelText = ""                    'This step is crucial!!! for undoing actions
    ric.SelText = Clipboard.GetText(1)
End Sub

Private Sub mnuRedo_Click()
    Redo
End Sub


Private Sub mnuUndo_Click()
    Undo
End Sub

Private Sub ric_Change()
    If Not trapUndo Then Exit Sub 'because trapping is disabled
    ' type New UndoElement
    Dim newElement As New UndoElement   'create new undo element
    Dim c%, l&
    For c% = 1 To RedoStack.Count
        RedoStack.Remove 1
    Next c%

    'set the values of the new element
    newElement.SelStart = ric.SelStart
    newElement.TextLen = Len(ric.Text)
    newElement.Text = ric.Text

    'add it to the undo stack
    UndoStack.Add Item:=newElement
    'enable controls accordingly
    EnableControls
End Sub

Private Sub ric_KeyDown(KeyCode As Integer, Shift As Integer)
    If Shift = 2 Then 'a control event (Ctrl + C, Ctrl + Z), etc.
           ' KeyCode = 0
    End If
End Sub


Private Sub ric_SelChange()
Dim ln&
    If Not trapUndo Then Exit Sub
    ln& = ric.SelLength
    mnuCut.Enabled = ln&    'disabled if length of selected text is 0
    mnuCopy.Enabled = ln&   'disabled if length of selected text is 0
    mnuPaste.Enabled = Len(Clipboard.GetText(1)) 'disabled if length of clipboard text is 0
    mnuDelete.Enabled = ln&  'disabled if length of selected text is 0
    'mnuSelectAll.Enabled = CBool(Len(Ric.Text)) 'disabled if length of textbox's text is 0
End Sub

Private Sub EnableControls()
    'cmdUndo.Enabled = UndoStack.Count > 1
    'cmdRedo.Enabled = RedoStack.Count > 0
    'mnuUndo.Enabled = cmdUndo.Enabled
    'mnuReDo.Enabled = cmdRedo.Enabled
    ric_SelChange
End Sub

Public Function Change(ByVal lParam1 As String, ByVal lParam2 As String, startSearch As Long) As String
Dim tempParam$
Dim d&
    If Len(lParam1) > Len(lParam2) Then 'swap
        tempParam$ = lParam1
        lParam1 = lParam2
        lParam2 = tempParam$
    End If
    d& = Len(lParam2) - Len(lParam1)
    Change = Mid(lParam2, startSearch - d&, d&)
End Function

Public Sub Undo()                   '//撤消
  'On Error Resume Next
Dim chg$, x&
Dim DeleteFlag As Boolean 'flag as to whether or not to delete text or append text
Dim objElement As Object, objElement2 As Object
    If UndoStack.Count > 1 And trapUndo Then 'we can proceed
        trapUndo = False
        DeleteFlag = UndoStack(UndoStack.Count - 1).TextLen < UndoStack(UndoStack.Count).TextLen
        If DeleteFlag Then  'delete some text
            'cmdDummy.SetFocus   'change focus of form
            x& = SendMessage(ric.hwnd, EM_HIDESELECTION, 1&, 1&)
            Set objElement = UndoStack(UndoStack.Count)
            Set objElement2 = UndoStack(UndoStack.Count - 1)
            ric.SelStart = objElement.SelStart - (objElement.TextLen - objElement2.TextLen)
            ric.SelLength = objElement.TextLen - objElement2.TextLen
            ric.SelText = ""
            x& = SendMessage(ric.hwnd, EM_HIDESELECTION, 0&, 0&)
        Else 'append something
            Set objElement = UndoStack(UndoStack.Count - 1)
            Set objElement2 = UndoStack(UndoStack.Count)
            chg$ = Change(objElement.Text, objElement2.Text, _
                objElement2.SelStart + 1 + Abs(Len(objElement.Text) - Len(objElement2.Text)))
            ric.SelStart = objElement2.SelStart
            ric.SelLength = 0
            ric.SelText = chg$
            ric.SelStart = objElement2.SelStart
            If Len(chg$) > 1 And chg$ <> vbCrLf Then
                ric.SelLength = Len(chg$)
            Else
                ric.SelStart = ric.SelStart + Len(chg$)
            End If
        End If
        RedoStack.Add Item:=UndoStack(UndoStack.Count)
        UndoStack.Remove UndoStack.Count
    End If
    EnableControls
    trapUndo = True
    ric.SetFocus
End Sub

Public Sub Redo()                  '//重做
Dim chg$
Dim DeleteFlag As Boolean 'flag as to whether or not to delete text or append text
Dim objElement As Object
    If RedoStack.Count > 0 And trapUndo Then
        trapUndo = False
        DeleteFlag = RedoStack(RedoStack.Count).TextLen < Len(ric.Text)
        If DeleteFlag Then  'delete last item
            Set objElement = RedoStack(RedoStack.Count)
            ric.SelStart = objElement.SelStart
            ric.SelLength = Len(ric.Text) - objElement.TextLen
            ric.SelText = ""
        Else 'append something
            Set objElement = RedoStack(RedoStack.Count)
            chg$ = Change(ric.Text, objElement.Text, objElement.SelStart + 1)
            ric.SelStart = objElement.SelStart - Len(chg$)
            ric.SelLength = 0
            ric.SelText = chg$
            ric.SelStart = objElement.SelStart - Len(chg$)
            If Len(chg$) > 1 And chg$ <> vbCrLf Then
                ric.SelLength = Len(chg$)
            Else
                ric.SelStart = ric.SelStart + Len(chg$)
            End If
        End If
        UndoStack.Add Item:=objElement
        RedoStack.Remove RedoStack.Count
    End If
    EnableControls
    trapUndo = True
    ric.SetFocus
End Sub