form1.frm

这是计算机系的一个课程设计题目

Private Sub Open_Click() '打开

    Dim aa
    If Changed = True Then
       aa = MsgBox("文件未保存,是否保存", vbYesNoCancel, "文件未保存")
       Select Case aa
       Case 6
         Save_Click
       Case 7
       openfile
       Case 2
          Exit Sub
       End Select
    Else
    openfile

    End If
    attr = GetAttr(filename)
    'If attr = 1 Or attr = 33 Then
    '   MsgBox "文件为只读打开", vbOKOnly, 文件只读
    'End If
End Sub
'打开文件子程序
Public Sub openfile()
        ' 设置标志
        CommonDialog1.Flags = cdlOFNHideReadOnly
        ' 设置过滤器
        CommonDialog1.Filter = "All Files (*.*)|*.*| RTF Files (*.rtf)|*.rtf| Text Files (*.txt)|*.txt"
        CommonDialog1.FilterIndex = 2
        ' 显示“打开”对话框
        CommonDialog1.ShowOpen
        
        filename = CommonDialog1.filename
        
        RichTextBox1.LoadFile filename
        Changed = False
End Sub

Private Sub Save_Click() '保存
    If attr = 33 Or filename = "" Then
       Saveas_Click
        Else: RichTextBox1.SaveFile filename
    End If
    Changed = False
End Sub

Private Sub Saveas_Click() '保存为
   Dim strNewFile As String
   CommonDialog1.Filter = "All Files (*.*)|*.*| RTF Files (*.rtf)|*.rtf|"
   CommonDialog1.FilterIndex = 2
   CommonDialog1.ShowSave
   strNewFile = CommonDialog1.filename

   If attr = 33 Or attr = 1 Then
      MsgBox "文件为只读属性,无法保存", vbOKOnly, "错误"
      Else: RichTextBox1.SaveFile strNewFile
   End If
   Changed = False
End Sub

Private Sub dump_Click() '打印
   CommonDialog1.Flags = cdlPDReturnDC + cdlPDNoPageNums
   If RichTextBox1.SelLength = 0 Then
      CommonDialog1.Flags = CommonDialog1.Flags + cdlPDAllPages
   Else
      CommonDialog1.Flags = CommonDialog1.Flags + cdlPDSelection
   End If
   CommonDialog1.ShowPrinter
   RichTextBox1.SelPrint CommonDialog1.hDC
End Sub

Private Sub Exit_Click() '退出
    Dim aa
    If Changed = True Then
       aa = MsgBox("文件未保存,是否保存", vbYesNoCancel, "文件未保存")
       Select Case aa
       Case 6
         Save_Click
         End
       Case 7
         End
       Case 2
          Exit Sub
       End Select
    Else: End
    End If
End Sub

Private Sub all_Click() '全选
    RichTextBox1.SelStart = 0
    RichTextBox1.SelLength = Len(RichTextBox1.Text)
End Sub

Private Sub Cut_Click() '剪切

    Clipboard.SetText RichTextBox1.SelText
    RichTextBox1.SelText = ""
End Sub

Private Sub Copy_Click() '复制
    Clipboard.SetText RichTextBox1.SelText
End Sub

Private Sub Paste_Click() '粘贴

    OpenORPaste = False
    RichTextBox1.SelText = ""
    RichTextBox1.SelText = Clipboard.GetText()
End Sub

Private Sub Del_Click() '删除
    RichTextBox1.SelText = ""
End Sub


Private Sub Find_Click() '查找
frmFind.FindandReplace RichTextBox1 '与frmFind窗体连接
frmFind.Text2.Visible = False 'text2隐藏
frmFind.Label2.Visible = False 'lable2隐藏
frmFind.Command2.Visible = False 'command2隐藏
End Sub

Private Sub Replace_Click() '替换
frmFind.FindandReplace RichTextBox1 '与frmFind窗体连接
frmFind.Text2.Visible = True 'text2显示
frmFind.Label2.Visible = True '显示lable2
frmFind.Command2.Visible = True '显示command2
End Sub

Private Sub Font_Click() '字体
    CommonDialog1.FontName = "宋体" '默认
    CommonDialog1.Flags = 3 '使对话框列出可用的打印机和屏幕字体。
    CommonDialog1.Action = 4 'action属性为4,显示"字体"对话框
    RichTextBox1.SelFontName = CommonDialog1.FontName 'richtextbox控件中的字体为选中的字体
    RichTextBox1.SelFontSize = CommonDialog1.FontSize 'richtextbox控件中的字号为选中的字号
    RichTextBox1.SelBold = CommonDialog1.FontBold 'CommonDialog1.FontBold设置richtextbox控件中是否为粗体
    RichTextBox1.SelItalic = CommonDialog1.FontItalic 'CommonDialog1.FontItalic设置richtextbox控件中是否为斜体
    RichTextBox1.SelUnderline = CommonDialog1.FontUnderline 'CommonDialog1.FontUnderline设置richtextbox控件中是否有下滑线
    RichTextBox1.SelStrikeThru = CommonDialog1.FontStrikethru 'CommonDialog1.FontStrikethru设置richtextbox控件中是否有删除线
End Sub

Private Sub Color_Click() '字体颜色
CommonDialog1.Flags = cdlCCRGBInit '字体颜色设置的窗体格式
CommonDialog1.Color = RGB(0, 0, 0) '初始化颜色为黑色
CommonDialog1.Action = 3 'action属性为3,显示"颜色"对话框
RichTextBox1.SelColor = CommonDialog1.Color '将richtextbox中的字体颜色改为选中颜色
End Sub

Private Sub Form_Unload(Cancel As Integer) '卸载窗体
    Dim aa
    If Changed = True Then '判断是否已保存当前文件
       aa = MsgBox("文件未保存,是否保存", vbYesNoCancel, "文件未保存") '提示当前文件未保存
       Select Case aa
       Case 6 '选是
         Save_Click '保存
         End '结束
       Case 7 '选否
         End '结束
       Case 2 '选取消
          Exit Sub '退出子过程
       End Select
    Else: End '结束
    End If
End Sub

Private Sub Left_Click() '左对齐
    RichTextBox1.SelAlignment = 0 'SelAlignment属性为0则靠左
End Sub

Private Sub Center_Click() '居中
 
    RichTextBox1.SelAlignment = 2 '为2则居中
End Sub
Private Sub Right_Click() '右对齐
    RichTextBox1.SelAlignment = 1 '为1则靠右
End Sub

Private Sub Undo_Click() '撤消

  Dim i As Integer
  i = SendMessage(RichTextBox1.hwnd, EM_UNDO, 0, 0)

End Sub

Private Sub RichTextBox1_Change()
    Changed = True '标记已修改
End Sub


Private Sub Picture_Click() '插入图片
    Clipboard.Clear '清空剪贴扳
    CommonDialog1.Filter = "位图(.bmp)文件|*.bmp|GIF(.gif)文件|*.gif|JPEG(.jpg)文件|*.jpg|" '限制可以插入的文件类型
    CommonDialog1.FilterIndex = 3 '默认在第三个,JPEG(.jpg)文件|*.jpg
    CommonDialog1.ShowOpen '现实路径窗口
    Clipboard.SetData LoadPicture(CommonDialog1.filename) '将图片加载到剪贴板
    RichTextBox1.SetFocus '移动光标到richtextbox1空间中
    SendKeys "^v", True      '模拟键盘输入(Ctrl+v)，将按键消息发送到活动窗口
    
End Sub

Private Sub Table_Click() '插入表格
RichTextBox1.OLEObjects.Add , , App.Path & "/temp.xls" '调用excl文件插入表格
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button.Index
Case 1 '新建
   New_Click
Case 2 '打开
   Open_Click
Case 3 '保存
   Save_Click
Case 4 '打印
   dump_Click

Case 6 '剪切
   Cut_Click
    
Case 7 '复制
   Copy_Click
    
Case 8 '粘贴
   Paste_Click
    
Case 9 '删除
   Del_Click
Case 11 '撤消
   Undo_Click
Case 12 '恢复
   'redo_click

Case 14 '查找
    Find_Click

Case 16 '粗体
    If IsNull(RichTextBox1.SelBold) = True Then
   '选择混合时运行的代码。
           RichTextBox1.SelBold = True
    ElseIf RichTextBox1.SelBold = False Then
   '选择不是粗体时运行的代码。
           RichTextBox1.SelBold = True
    ElseIf RichTextBox1.SelBold = True Then
           RichTextBox1.SelBold = False
    End If


Case 17 '斜体
    If IsNull(RichTextBox1.SelItalic) = True Then '判断属性是否为空,为空则为混合型
   
   
           RichTextBox1.SelItalic = True '混合时运行的代码。
    ElseIf RichTextBox1.SelItalic = False Then '判断不是斜体
  
           RichTextBox1.SelItalic = True '不是斜体时改为斜体
    ElseIf RichTextBox1.SelItalic = True Then '判断是否为斜体
           RichTextBox1.SelItalic = False '斜体是改为不斜体 其他的类似
    End If
    
Case 18 '下滑线
    If IsNull(RichTextBox1.SelUnderline) = True Then
   '选择混合时运行的代码。
           RichTextBox1.SelUnderline = True
    ElseIf RichTextBox1.SelUnderline = False Then
   '选择没有下滑线时的代码。
           RichTextBox1.SelUnderline = True
    ElseIf RichTextBox1.SelUnderline = True Then
           RichTextBox1.SelUnderline = False
    End If
    
Case 19 '删除线
    If IsNull(RichTextBox1.SelStrikeThru) = True Then
   '选择混合时运行的代码。
           RichTextBox1.SelStrikeThru = True
    ElseIf RichTextBox1.SelStrikeThru = False Then
   '选择没有删除线时的代码。
           RichTextBox1.SelStrikeThru = True
    ElseIf RichTextBox1.SelStrikeThru = True Then
           RichTextBox1.SelStrikeThru = False
    End If

Case 21 '左对齐
    Left_Click

Case 22 '居中
    Center_Click

Case 23 '右对齐
    Right_Click

Case 25 '字体
    Font_Click
    
Case 26 '字体颜色
    Color_Click
    
Case 28 '插入表格
    Table_Click
Case 29 '插入图片
    Picture_Click


End Select
End Sub