'欢迎与我交流：luluhai@eastday.com
所有源代码均在这里下载：http://www.up2e.com/resource.php
'本程序代码是VB.NET课程设计的作业'代码编写及整理：路海
Imports System.Drawing.PrintingImports System.Drawing.FontPublic Class formMain Inherits System.Windows.Forms.Form
#Region " Windows 窗体设计器生成的代码 "
Public Sub New() MyBase.New()
'该调用是 Windows 窗体设计器所必需的。 InitializeComponent()
'在 InitializeComponent() 调用之后添加任何初始化
End Sub
'窗体重写处置以清理组件列表。 Protected Overloads Overrides Sub Dispose(ByVal disposing As Boolean) If disposing Then If Not (components Is Nothing) Then components.Dispose() End If End If MyBase.Dispose(disposing) End Sub
'Windows 窗体设计器所必需的 Private components As System.ComponentModel.IContainer
'注意：以下过程是 Windows 窗体设计器所必需的 '可以使用 Windows 窗体设计器修改此过程。 '不要使用代码编辑器修改它。 Friend WithEvents MainMenu1 As System.Windows.Forms.MainMenu Friend WithEvents mFile As System.Windows.Forms.MenuItem Friend WithEvents mNew As System.Windows.Forms.MenuItem Friend WithEvents mOpen As System.Windows.Forms.MenuItem '..................... '....................... '..................... '由于很长，我把他略去了 '................. '.................. Me.Panel1.SuspendLayout() Me.SuspendLayout() ' 'MainMenu1 ' Me.MainMenu1.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.mFile, Me.mEdit, Me.mView, Me.mFormat, Me.mHelp}) ' 'mFile ' Me.mFile.Index = 0 Me.mFile.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.mNew, Me.mOpen, Me.mSave, Me.mSaveas, Me.MenuItem6, Me.mPrint, Me.mPrintpreview, Me.mPagesetup, Me.MenuItem10, Me.mExit}) Me.mFile.Text = "文件(&F)" ' 'mNew ' Me.mNew.Index = 0 Me.mNew.Shortcut = System.Windows.Forms.Shortcut.CtrlN Me.mNew.Text = "新建(&N)..." ' 'mOpen ' Me.mOpen.Index = 1 Me.mOpen.Shortcut = System.Windows.Forms.Shortcut.CtrlO Me.mOpen.Text = "打开(&O)... " ' 'mSave ' Me.mSave.Index = 2 Me.mSave.Shortcut = System.Windows.Forms.Shortcut.CtrlS Me.mSave.Text = "保存(&S) " ' 'mSaveas ' Me.mSaveas.Index = 3 Me.mSaveas.Text = "另存为(&A)..." ' 'MenuItem6 ' Me.MenuItem6.Index = 4 Me.MenuItem6.Text = "-" ' 'mPrint ' Me.mPrint.Index = 5 Me.mPrint.Shortcut = System.Windows.Forms.Shortcut.CtrlP Me.mPrint.Text = "打印(&P)..." ' 'mPrintpreview ' Me.mPrintpreview.Index = 6 Me.mPrintpreview.Text = "打印预览(&V)" ' 'mPagesetup ' Me.mPagesetup.Index = 7 Me.mPagesetup.Text = "页面设置(&U)..." ' 'MenuItem10 ' Me.MenuItem10.Index = 8 Me.MenuItem10.Text = "-" ' 'mExit ' Me.mExit.Index = 9 Me.mExit.Text = "退出(&X)" ' 'mEdit ' Me.mEdit.Index = 1 Me.mEdit.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.mUndo, Me.MenuItem1, Me.mCut, Me.mCopy, Me.mPaste, Me.mClear, Me.mSelectall, Me.MenuItem21, Me.mFind, Me.mFindnext, Me.mReplace}) Me.mEdit.Text = "编辑(&E)" ' 'mUndo ' Me.mUndo.Index = 0 Me.mUndo.Shortcut = System.Windows.Forms.Shortcut.CtrlZ Me.mUndo.Text = "撤销(&U)" ' 'MenuItem1 ' Me.MenuItem1.Index = 1 Me.MenuItem1.Text = "-" ' 'mCut ' Me.mCut.Index = 2 Me.mCut.Shortcut = System.Windows.Forms.Shortcut.CtrlX Me.mCut.Text = "剪切(&T)" ' 'mCopy ' Me.mCopy.Index = 3 Me.mCopy.Shortcut = System.Windows.Forms.Shortcut.CtrlC Me.mCopy.Text = "复制(&C)" ' 'mPaste ' Me.mPaste.Index = 4 Me.mPaste.Shortcut = System.Windows.Forms.Shortcut.CtrlP Me.mPaste.Text = "粘贴(&P)" ' 'mClear ' Me.mClear.Index = 5 Me.mClear.Shortcut = System.Windows.Forms.Shortcut.Del Me.mClear.Text = "清除(&A)" ' 'mSelectall ' Me.mSelectall.Index = 6 Me.mSelectall.Shortcut = System.Windows.Forms.Shortcut.CtrlA Me.mSelectall.Text = "全选(&L)" ' 'MenuItem21 ' Me.MenuItem21.Index = 7 Me.MenuItem21.Text = "-" ' 'mFind ' Me.mFind.Index = 8 Me.mFind.Shortcut = System.Windows.Forms.Shortcut.CtrlF Me.mFind.Text = "查找(&F)..." ' 'mFindnext ' Me.mFindnext.Index = 9 Me.mFindnext.Shortcut = System.Windows.Forms.Shortcut.F3 Me.mFindnext.Text = "查找下一个(&N)" ' 'mReplace ' Me.mReplace.Index = 10 Me.mReplace.Shortcut = System.Windows.Forms.Shortcut.CtrlH Me.mReplace.Text = "替换(&E)..." ' 'mView ' Me.mView.Index = 2 Me.mView.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.mStatusbar}) Me.mView.Text = "查看(&V)" ' 'mStatusbar ' Me.mStatusbar.Checked = True Me.mStatusbar.Index = 0 Me.mStatusbar.Text = "状态栏(&S)" ' 'mFormat ' Me.mFormat.Index = 3 Me.mFormat.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.mFont, Me.MenuItem2}) Me.mFormat.Text = "格式(&D)" ' 'mFont ' Me.mFont.Index = 0 Me.mFont.Text = "字体(&F)..." ' 'MenuItem2 ' Me.MenuItem2.Index = 1 Me.MenuItem2.Text = "颜色(&C)..." ' 'mHelp ' Me.mHelp.Index = 4 Me.mHelp.MenuItems.AddRange(New System.Windows.Forms.MenuItem() {Me.mHelptopics, Me.MenuItem34, Me.mAbout}) Me.mHelp.Text = "帮助(&H)" ' 'mHelptopics ' Me.mHelptopics.Index = 0 Me.mHelptopics.Text = "帮助主题(&H)" ' 'MenuItem34 ' Me.MenuItem34.Index = 1 Me.MenuItem34.Text = "-" ' 'mAbout ' Me.mAbout.Index = 2 Me.mAbout.Text = "关于本写字板作业(&A)" ' 'SaveFileDialog1 ' Me.SaveFileDialog1.FileName = "doc1" ' 'ToolBar1 ' Me.ToolBar1.AllowDrop = True Me.ToolBar1.AutoSize = False Me.ToolBar1.Buttons.AddRange(New System.Windows.Forms.ToolBarButton() {Me.tbbNew, Me.tbbOpen, Me.tbbSave, Me.ToolBarButton1, Me.ToolBarButton2, Me.vbbPrint, Me.tbbPreview, Me.ToolBarButton3, Me.ToolBarButton4, Me.tbbFind, Me.ToolBarButton5, Me.ToolBarButton6, Me.tbbCut, Me.tbbCopy, Me.tbbPaste, Me.tbbUndo}) Me.ToolBar1.ButtonSize = New System.Drawing.Size(25, 24) Me.ToolBar1.DropDownArrows = True Me.ToolBar1.ImageList = Me.ImageList1 Me.ToolBar1.Name = "ToolBar1" Me.ToolBar1.ShowToolTips = True Me.ToolBar1.Size = New System.Drawing.Size(688, 32) Me.ToolBar1.TabIndex = 0 ' 'tbbNew ' Me.tbbNew.ImageIndex = 5 Me.tbbNew.ToolTipText = "新建" ' 'tbbOpen ' Me.tbbOpen.ImageIndex = 6 Me.tbbOpen.ToolTipText = "打开" ' 'tbbSave ' Me.tbbSave.ImageIndex = 10 Me.tbbSave.ToolTipText = "保存" ' 'ToolBarButton1 ' Me.ToolBarButton1.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'ToolBarButton2 ' Me.ToolBarButton2.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'vbbPrint ' Me.vbbPrint.ImageIndex = 9 Me.vbbPrint.ToolTipText = "打印" ' 'tbbPreview ' Me.tbbPreview.ImageIndex = 8 Me.tbbPreview.ToolTipText = "打印预览" ' 'ToolBarButton3 ' Me.ToolBarButton3.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'ToolBarButton4 ' Me.ToolBarButton4.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'tbbFind ' Me.tbbFind.ImageIndex = 12 Me.tbbFind.ToolTipText = "查找" ' 'ToolBarButton5 ' Me.ToolBarButton5.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'ToolBarButton6 ' Me.ToolBarButton6.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'tbbCut ' Me.tbbCut.ImageIndex = 4 Me.tbbCut.ToolTipText = "剪切" ' 'tbbCopy ' Me.tbbCopy.ImageIndex = 3 Me.tbbCopy.ToolTipText = "复制" ' 'tbbPaste ' Me.tbbPaste.ImageIndex = 7 Me.tbbPaste.ToolTipText = "粘贴" ' 'tbbUndo ' Me.tbbUndo.ImageIndex = 11 Me.tbbUndo.ToolTipText = "撤销" ' 'ImageList1 ' Me.ImageList1.ColorDepth = System.Windows.Forms.ColorDepth.Depth8Bit Me.ImageList1.ImageSize = New System.Drawing.Size(16, 16) Me.ImageList1.ImageStream = CType(resources.GetObject("ImageList1.ImageStream"), System.Windows.Forms.ImageListStreamer) Me.ImageList1.TransparentColor = System.Drawing.Color.Transparent ' 'rtbox ' Me.rtbox.Anchor = (((System.Windows.Forms.AnchorStyles.Top Or System.Windows.Forms.AnchorStyles.Bottom) _ Or System.Windows.Forms.AnchorStyles.Left) _ Or System.Windows.Forms.AnchorStyles.Right) Me.rtbox.Font = New System.Drawing.Font("宋体", 9.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(134, Byte)) Me.rtbox.Location = New System.Drawing.Point(0, 64) Me.rtbox.Name = "rtbox" Me.rtbox.Size = New System.Drawing.Size(688, 424) Me.rtbox.TabIndex = 3 Me.rtbox.Text = "" ' 'PrintDialog1 ' Me.PrintDialog1.Document = Me.PrintDocument1 ' 'comboxFont ' Me.comboxFont.Font = New System.Drawing.Font("宋体", 9.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(134, Byte)) Me.comboxFont.Location = New System.Drawing.Point(184, 40) Me.comboxFont.Name = "comboxFont" Me.comboxFont.Size = New System.Drawing.Size(121, 20) Me.comboxFont.TabIndex = 5 Me.comboxFont.Text = "字体" ' 'comboxSize ' Me.comboxSize.Items.AddRange(New Object() {"8", "9", "10", "11", "12", "14", "16", "18", "20", "22", "24", "26", "28", "36", "48", "72"}) Me.comboxSize.Location = New System.Drawing.Point(304, 40) Me.comboxSize.Name = "comboxSize" Me.comboxSize.Size = New System.Drawing.Size(48, 20) Me.comboxSize.TabIndex = 6 Me.comboxSize.Text = "大小" ' 'tbbbold ' Me.tbbbold.ImageIndex = 0 Me.tbbbold.Style = System.Windows.Forms.ToolBarButtonStyle.ToggleButton Me.tbbbold.ToolTipText = "加粗" ' 'tbbi ' Me.tbbi.ImageIndex = 1 Me.tbbi.Style = System.Windows.Forms.ToolBarButtonStyle.ToggleButton Me.tbbi.ToolTipText = "斜体" ' 'tbbu ' Me.tbbu.ImageIndex = 2 Me.tbbu.Style = System.Windows.Forms.ToolBarButtonStyle.ToggleButton Me.tbbu.ToolTipText = "下划线" ' 'tbbcolor ' Me.tbbcolor.ImageIndex = 16 Me.tbbcolor.ToolTipText = "这个是颜色！因为找不到合适的。" ' 'ToolBarButton8 ' Me.ToolBarButton8.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'ToolBarButton7 ' Me.ToolBarButton7.Style = System.Windows.Forms.ToolBarButtonStyle.Separator ' 'tbbleft ' Me.tbbleft.ImageIndex = 13 Me.tbbleft.Style = System.Windows.Forms.ToolBarButtonStyle.ToggleButton Me.tbbleft.ToolTipText = "靠左" ' 'tbbmiddle ' Me.tbbmiddle.ImageIndex = 15 Me.tbbmiddle.Style = System.Windows.Forms.ToolBarButtonStyle.ToggleButton Me.tbbmiddle.ToolTipText = "靠中" ' 'tbbright ' Me.tbbright.ImageIndex = 14 Me.tbbright.Style = System.Windows.Forms.ToolBarButtonStyle.ToggleButton Me.tbbright.ToolTipText = "靠右" ' 'ToolBar2 ' Me.ToolBar2.Buttons.AddRange(New System.Windows.Forms.ToolBarButton() {Me.tbbbold, Me.tbbi, Me.tbbu, Me.tbbcolor, Me.ToolBarButton8, Me.ToolBarButton7, Me.tbbleft, Me.tbbmiddle, Me.tbbright}) Me.ToolBar2.ButtonSize = New System.Drawing.Size(23, 22) Me.ToolBar2.DropDownArrows = True Me.ToolBar2.ImageList = Me.ImageList1 Me.ToolBar2.Location = New System.Drawing.Point(0, 32) Me.ToolBar2.Name = "ToolBar2" Me.ToolBar2.ShowToolTips = True Me.ToolBar2.Size = New System.Drawing.Size(688, 25) Me.ToolBar2.TabIndex = 7 ' 'StatusBar1 ' Me.StatusBar1.Location = New System.Drawing.Point(0, 467) Me.StatusBar1.Name = "StatusBar1" Me.StatusBar1.Size = New System.Drawing.Size(688, 22) Me.StatusBar1.TabIndex = 8 ' 'Panel1 ' Me.Panel1.BorderStyle = System.Windows.Forms.BorderStyle.FixedSingle Me.Panel1.Controls.AddRange(New System.Windows.Forms.Control() {Me.PictureBox1, Me.closepanel, Me.Label1, Me.mpreplace, Me.findnext, Me.find, Me.rpbox, Me.txtbox}) Me.Panel1.Location = New System.Drawing.Point(192, 160) Me.Panel1.Name = "Panel1" Me.Panel1.Size = New System.Drawing.Size(272, 96) Me.Panel1.TabIndex = 9 Me.Panel1.Visible = False ' 'PictureBox1 ' Me.PictureBox1.Image = CType(resources.GetObject("PictureBox1.Image"), System.Drawing.Bitmap) Me.PictureBox1.Location = New System.Drawing.Point(8, 8) Me.PictureBox1.Name = "PictureBox1" Me.PictureBox1.Size = New System.Drawing.Size(16, 16) Me.PictureBox1.TabIndex = 7 Me.PictureBox1.TabStop = False ' 'closepanel ' Me.closepanel.Font = New System.Drawing.Font("宋体", 9.0!, System.Drawing.FontStyle.Regular, System.Drawing.GraphicsUnit.Point, CType(134, Byte)) Me.closepanel.ForeColor = System.Drawing.Color.Black Me.closepanel.Location = New System.Drawing.Point(240, 64) Me.closepanel.Name = "closepanel" Me.closepanel.Size = New System.Drawing.Size(24, 24) Me.closepanel.TabIndex = 6 Me.closepanel.Text = "关" ' 'Label1 ' Me.Label1.Location = New System.Drawing.Point(24, 8) Me.Label1.Name = "Label1" Me.Label1.Size = New System.Drawing.Size(61, 16) Me.Label1.TabIndex = 5 Me.Label1.Text = "查找-可拖" ' 'mpreplace ' Me.mpreplace.Location = New System.Drawing.Point(112, 64) Me.mpreplace.Name = "mpreplace" Me.mpreplace.Size = New System.Drawing.Size(72, 23) Me.mpreplace.TabIndex = 4 Me.mpreplace.Text = "替换" ' 'findnext ' Me.findnext.Location = New System.Drawing.Point(192, 32) Me.findnext.Name = "findnext" Me.findnext.TabIndex = 3 Me.findnext.Text = "下一个" ' 'find ' Me.find.Location = New System.Drawing.Point(112, 32) Me.find.Name = "find" Me.find.Size = New System.Drawing.Size(72, 23) Me.find.TabIndex = 2 Me.find.Text = "查找" ' 'rpbox ' Me.rpbox.Location = New System.Drawing.Point(8, 64) Me.rpbox.Name = "rpbox" Me.rpbox.TabIndex = 1 Me.rpbox.Text = "" ' 'txtbox ' Me.txtbox.Location = New System.Drawing.Point(8, 32) Me.txtbox.Name = "txtbox" Me.txtbox.TabIndex = 0 Me.txtbox.Text = "" ' 'formMain ' Me.AutoScaleBaseSize = New System.Drawing.Size(6, 14) Me.ClientSize = New System.Drawing.Size(688, 489) Me.Controls.AddRange(New System.Windows.Forms.Control() {Me.Panel1, Me.StatusBar1, Me.comboxSize, Me.comboxFont, Me.ToolBar2, Me.rtbox, Me.ToolBar1}) Me.Icon = CType(resources.GetObject("$this.Icon"), System.Drawing.Icon) Me.Menu = Me.MainMenu1 Me.Name = "formMain" Me.Text = "VB.NET课程设计作业2-写字板:::::By SunnyGroup 2002:::Shanghai Fisheries University:::::" Me.Panel1.ResumeLayout(False) Me.ResumeLayout(False)
End Sub
#End Region
'声明一个全局boolean变量，用来标记richtextbox中文本变化和保存情况 Dim bSave As Boolean
'下面这段程序用于对对话框属性和全局变量进行初始化设置 Private Sub formMain_Load(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MyBase.Load '为bSave首先赋初值 bSave = True '为savefiledialog进行初始化 SaveFileDialog1.FileName = "" SaveFileDialog1.DefaultExt = "txt" SaveFileDialog1.Filter = "Text files (*.txt) |*.txt|All files (*.*) |*.*" SaveFileDialog1.Title = "保存文件.." '为openfiledialog进行初始化 OpenFileDialog1.FileName = "" OpenFileDialog1.DefaultExt = "txt" OpenFileDialog1.Filter = "Text files (*.txt) |*.txt|All files (*.*) |*.*" OpenFileDialog1.Title = "打开文件.." '下面这段代码是加载当地系统中所有字体到Combobox中 Dim allfonts As FontFamily For Each allfonts In System.Drawing.FontFamily.Families comboxFont.Items.Add(allfonts.Name) Next End Sub
Private Sub rtbox_TextChanged(ByVal sender As Object, ByVal e As System.EventArgs) Handles rtbox.TextChanged '文本发生了改变，则将变量bSave置为False bSave = False End Sub
'******************************************************************************************** '字体
'下面这个函数是用来去除用户指定的字体样式，如加粗，下划线等等 Public Sub RemoveFontStyle(ByVal rtb As RichTextBox, _ ByVal style As System.Drawing.FontStyle) ' 如果选择文本的长度大于0，将一个一个去除样式。 ' 这是十分必要的！因为选择的文本中可能有许多不同的样式，而我们的原意是 ' 保持所有原来的样式，除了那个要被去除的样式 If rtb.SelectionLength > 0 Then Dim selStart As Integer = rtb.SelectionStart Dim selLength As Integer = rtb.SelectionLength Dim currFont As System.Drawing.Font Dim currStyle As System.Drawing.FontStyle
Dim i As Integer For i = 0 To selLength - 1 ' 选择一个字符 rtb.Select(selStart + i, 1) ' 得到被选择字符的字体 currFont = rtb.SelectionFont ' 得到被选择字符的样式，同时去除要被除去的那个样式 currStyle = currFont.Style currStyle = currStyle And Not style ' 然后赋予这些字符新的字体和样式 rtb.SelectionFont = New Font(currFont.FontFamily, currFont.Size, _ currStyle) Next ' 保持原有的选择 rtb.Select(selStart, selLength) Else rtb.SelectionFont = New Font(rtb.SelectionFont, _ rtb.SelectionFont.Style And Not style) End If End Sub
'下面这个函数是用来增加字体的样式，比如加粗，下划线等等 Public Sub AddFontStyle(ByVal rtb As RichTextBox, _ ByVal style As System.Drawing.FontStyle) ' 如果选择的文本长度大于0，将一个一个字符地增加样式。 '这是十分必要的!因为被选择的字符可能同时含有多种样式， ' 而我们的原意只是保持所有原来的样式，同时增加上指定的样式
If rtb.SelectionLength > 0 Then Dim selStart As Integer = rtb.SelectionStart Dim selLength As Integer = rtb.SelectionLength Dim currFont As System.Drawing.Font Dim currStyle As System.Drawing.FontStyle
Dim i As Integer For i = 0 To selLength - 1 ' 选择的字符 rtb.Select(selStart + i, 1) ' 得到被选择字符的字体 currFont = rtb.SelectionFont ' 得到现在的样式，同时增加指定的样式 currStyle = currFont.Style currStyle = currStyle Or style ' 然后使字符拥有新的字体和新的样式，有可能出现异常， '因为不是所有字体都支持所有的样式，所以这里捕捉异常 Try rtb.SelectionFont = New Font(currFont.FontFamily, currFont.Size, _ currStyle) Catch ex As Exception End Try Next
rtb.Select(selStart, selLength) Else rtb.SelectionFont = New Font(rtb.SelectionFont, _ rtb.SelectionFont.Style Or style) End If End Sub
'并不是所有的字体都支持所有的样式，下面这个函数是用来检查新字体是否支持选择的样式，若不支持，则移除该样式 '使用举例： GetSafeStyleForFontFamily(richTextBox1.SelectionFont.FontFamily,richTextBox1.SelectionFont.Style) Public Function GetSafeStyleForFontFamily(ByVal fontFam As FontFamily, _ ByVal style As FontStyle) As FontStyle ' 移除不支持的样式 If (style And FontStyle.Regular) = FontStyle.Regular Then If Not fontFam.IsStyleAvailable(FontStyle.Regular) Then style = style And Not FontStyle.Regular End If End If If (style And FontStyle.Bold) = FontStyle.Bold Then If Not fontFam.IsStyleAvailable(FontStyle.Bold) Then style = style And Not FontStyle.Bold End If End If If (style And FontStyle.Italic) = FontStyle.Italic Then If Not fontFam.IsStyleAvailable(FontStyle.Italic) Then style = style And Not FontStyle.Italic End If End If If (style And FontStyle.Underline) = FontStyle.Underline Then If Not fontFam.IsStyleAvailable(FontStyle.Underline) Then style = style And Not FontStyle.Underline End If End If If (style And FontStyle.Strikeout) = FontStyle.Strikeout Then If Not fontFam.IsStyleAvailable(FontStyle.Strikeout) Then style = style And Not FontStyle.Strikeout End If End If Return style End Function
'下面这个SetFontSize函数是用来设置字体的大小 Public Sub SetFontSize(ByVal rtb As RichTextBox, ByVal fontSize As Single)
If rtb.SelectionLength > 0 Then Dim selStart As Integer = rtb.SelectionStart Dim selLength As Integer = rtb.SelectionLength Dim currFont As System.Drawing.Font
Dim i As Integer For i = 0 To selLength - 1
rtb.Select(selStart + i, 1)
currFont = rtb.SelectionFont
rtb.SelectionFont = New Font(currFont.FontFamily, fontSize, _ currFont.Style) Next
rtb.Select(selStart, selLength) Else rtb.SelectionFont = New Font(rtb.SelectionFont.Name, fontSize, _ rtb.SelectionFont.Style) End If End Sub
'下面这个SetFontFamily函数是用来设置字体的变化 Public Sub SetFontFamily(ByVal rtb As RichTextBox, ByVal fontName As String) Dim fontFam As New System.Drawing.FontFamily(fontName) Dim style As System.Drawing.FontStyle
If rtb.SelectionLength > 0 Then Dim selStart As Integer = rtb.SelectionStart Dim selLength As Integer = rtb.SelectionLength
Dim i As Integer For i = 0 To selLength - 1
rtb.Select(selStart + i, 1)
style = GetSafeStyleForFontFamily(fontFam, rtb.SelectionFont.Style)
rtb.SelectionFont = New Font(fontFam, rtb.SelectionFont.Size, style) Next
rtb.Select(selStart, selLength) Else
style = GetSafeStyleForFontFamily(fontFam, rtb.SelectionFont.Style)
rtb.SelectionFont = New Font(fontFam, rtb.SelectionFont.Size, style) End If End Sub
'************************************************************************************
'下面这个函数是用来新建文件 Private Sub newfile() Dim flag As Integer '如果文本已经被保存，则清空rtbox内容，所有变量重置以新建文本 If bSave Then rtbox.Clear() SaveFileDialog1.FileName = "" bSave = True Else '如果文本没有保存，则提示是否要保存 flag = MessageBox.Show("文件内容已更改，想保存文件吗？？", "info", MessageBoxButtons.YesNoCancel, MessageBoxIcon.Information) Select Case flag 'case 6是当用户选择了“保存”，则执行保存文件的操作 Case 6 '如果没有选择要保存的文件名，则弹出保存对话框，由用户选择要保存的文件名后保存文本 If SaveFileDialog1.FileName = "" Then If SaveFileDialog1.ShowDialog Then rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If Else '如果已经选择了要保存的文件名，则保存文本到文件中 rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If '然后就是清空rtbox的内容，重置变量以新建文本 bSave = True rtbox.Clear() SaveFileDialog1.FileName = ""
'case 7就是当用户选择了no也就是不保存时，立即清空rtbox内容，重置变量以新建文本 Case 7 rtbox.Clear() SaveFileDialog1.FileName = "" bSave = True
'case else就是当用户选择了取消，则取消新建操作，也就是Do Nothing Case Else End Select End If End Sub
'下面这个函数是用来打开文件 Private Sub openfile() Dim flag As Integer '如果文本内容没有保存，询问用户是否保存 If Not bSave Then flag = MessageBox.Show("文件内容已更改，想保存文件吗？？", "info", MessageBoxButtons.YesNoCancel, MessageBoxIcon.Information) Select Case flag 'case 6是当用户选择了“保存”，则执行保存文件的操作 Case 6 '如果没有选择要保存的文件名，则弹出保存对话框，由用户选择要保存的文件名后保存文本 If SaveFileDialog1.FileName = "" Then If SaveFileDialog1.ShowDialog Then rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If Else '如果已经选择了要保存的文件名，则保存文本到文件中 rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If '弹出打开文件对话框，执行打开文件操作 bSave = True If OpenFileDialog1.ShowDialog() = DialogResult.OK Then rtbox.LoadFile(OpenFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If
'case 7的意思是如果用户选择了“不保存”，则直接执行打开文件操作 Case 7 If OpenFileDialog1.ShowDialog() = DialogResult.OK Then rtbox.LoadFile(OpenFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If bSave = True
'case else也就是用户选择了取消 Case Else End Select
'else文本已经保存，直接执行打开文件操作 Else If OpenFileDialog1.ShowDialog() = DialogResult.OK Then rtbox.LoadFile(OpenFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If bSave = True End If End Sub
'下面这个函数是用来保存文件 Private Sub savefile() '如果没有选择要保存的文件名，则弹出保存对话框，由用户选择要保存的文件名后保存文本 If SaveFileDialog1.FileName = "" Then If SaveFileDialog1.ShowDialog Then rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If Else '如果已经选择了要保存的文件名，则保存文本到文件中 rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If bSave = True End Sub
'***************************************************************************** '打印，打印预览
' 必须确定所有的打印事件都是针对同一个 PrintDocument Private WithEvents pdoc As New PrintDocument()
' 打印文件是一个函数性的打印事件，每当要打印时该事件被触发 ' 下面是一个非常快速和有用的精确计算要打印的文本是否能够被包括到整张打印页面 '是我从微软站点上得到的资料，我把它应用到了我的程序中 Private Sub pdoc_PrintPage(ByVal sender As Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs) Handles pdoc.PrintPage ' Declare a variable to hold the position of the last printed char. Declare ' as static so that subsequent PrintPage events can reference it. Static intCurrentChar As Int32 ' Initialize the font to be used for printing. Dim font As New font("Microsoft Sans Serif", 24)
Dim intPrintAreaHeight, intPrintAreaWidth, marginLeft, marginTop As Int32 With pdoc.DefaultPageSettings ' Initialize local variables that contain the bounds of the printing ' area rectangle. intPrintAreaHeight = .PaperSize.Height - .Margins.Top - .Margins.Bottom intPrintAreaWidth = .PaperSize.Width - .Margins.Left - .Margins.Right
' Initialize local variables to hold margin values that will serve ' as the X and Y coordinates for the upper left corner of the printing ' area rectangle. marginLeft = .Margins.Left ' X coordinate marginTop = .Margins.Top ' Y coordinate End With
' If the user selected Landscape mode, swap the printing area height ' and width. If pdoc.DefaultPageSettings.Landscape Then Dim intTemp As Int32 intTemp = intPrintAreaHeight intPrintAreaHeight = intPrintAreaWidth intPrintAreaWidth = intTemp End If
' Calculate the total number of lines in the document based on the height of ' the printing area and the height of the font. Dim intLineCount As Int32 = CInt(intPrintAreaHeight / font.Height) ' Initialize the rectangle structure that defines the printing area. Dim rectPrintingArea As New RectangleF(marginLeft, marginTop, intPrintAreaWidth, intPrintAreaHeight)
' Instantiate the StringFormat class, which encapsulates text layout ' information (such as alignment and line spacing), display manipulations ' (such as ellipsis insertion and national digit substitution) and OpenType ' features. Use of StringFormat causes MeasureString and DrawString to use ' only an integer number of lines when printing each page, ignoring partial ' lines that would otherwise likely be printed if the number of lines per ' page do not divide up cleanly for each page (which is usually the case). ' See further discussion in the SDK documentation about StringFormatFlags. Dim fmt As New StringFormat(StringFormatFlags.LineLimit) ' Call MeasureString to determine the number of characters that will fit in ' the printing area rectangle. The CharFitted Int32 is passed ByRef and used ' later when calculating intCurrentChar and thus HasMorePages. LinesFilled ' is not needed for this sample but must be passed when passing CharsFitted. ' Mid is used to pass the segment of remaining text left off from the ' previous page of printing (recall that intCurrentChar was declared as ' static. Dim intLinesFilled, intCharsFitted As Int32 e.Graphics.MeasureString(Mid(rtbox.Text, intCurrentChar + 1), font, _ New SizeF(intPrintAreaWidth, intPrintAreaHeight), fmt, _ intCharsFitted, intLinesFilled)
' Print the text to the page. e.Graphics.DrawString(Mid(rtbox.Text, intCurrentChar + 1), font, _ Brushes.Black, rectPrintingArea, fmt)
' Advance the current char to the last char printed on this page. As ' intCurrentChar is a static variable, its value can be used for the next ' page to be printed. It is advanced by 1 and passed to Mid() to print the ' next page (see above in MeasureString()). intCurrentChar += intCharsFitted
' HasMorePages tells the printing module whether another PrintPage event ' should be fired. If intCurrentChar < rtbox.Text.Length Then e.HasMorePages = True Else e.HasMorePages = False ' You must explicitly reset intCurrentChar as it is static. intCurrentChar = 0 End If End Sub
Private Sub printpreview() Dim ppd As New PrintPreviewDialog() Try ppd.Document = pdoc ppd.ShowDialog() Catch exp As Exception MessageBox.Show("有错误发生！！不能预览 ！" & _ "确信现在你是否能够 " & _ "连接到一个打印机？" & _ "然后预览才可以.", Me.Text, _ MessageBoxButtons.OK, MessageBoxIcon.Error) End Try End Sub
Private Sub mPrintpreview_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mPrintpreview.Click printpreview() End Sub
Private Sub mPagesetup_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mPagesetup.Click Dim psd As New PageSetupDialog() With psd .Document = pdoc .PageSettings = pdoc.DefaultPageSettings End With
If psd.ShowDialog = DialogResult.OK Then pdoc.DefaultPageSettings = psd.PageSettings End If End Sub
Private Sub printfile() Dim dialog As New PrintDialog() dialog.Document = pdoc
If dialog.ShowDialog = DialogResult.OK Then pdoc.Print() End If End Sub '********************************************************************************
Private Sub mNew_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mNew.Click newfile() End Sub
Private Sub mOpen_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mOpen.Click openfile() End Sub
Private Sub mSave_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mSave.Click savefile() End Sub
Private Sub mSaveas_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mSaveas.Click '将保存文件窗口标题改为“文件另存为” SaveFileDialog1.Title = "文件另存为" If SaveFileDialog1.ShowDialog() = DialogResult.OK Then rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) bSave = True End If '将标题改回 SaveFileDialog1.Title = "保存文件" End Sub
Private Sub mExit_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mExit.Click '退出操作 Close() End Sub
'在关闭程序之前，判断文本是否需要保存 Private Sub formMain_Closing(ByVal sender As Object, ByVal e As System.ComponentModel.CancelEventArgs) Handles MyBase.Closing If bSave = False Then Dim flag As Integer flag = MessageBox.Show("文件内容已更改，想保存文件吗？？", "info", MessageBoxButtons.YesNo, MessageBoxIcon.Information) Select Case flag 'case 6是当用户选择了“保存”，则执行保存文件的操作 Case 6 '如果没有选择要保存的文件名，则弹出保存对话框，由用户选择要保存的文件名后保存文本 If SaveFileDialog1.FileName = "" Then If SaveFileDialog1.ShowDialog Then rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If Else '如果已经选择了要保存的文件名，则保存文本到文件中 rtbox.SaveFile(SaveFileDialog1.FileName, RichTextBoxStreamType.PlainText) End If Case Else '不保存 End Select End If End Sub
'关于显示“关于”窗体的代码 Private Sub mAbout_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mAbout.Click '首先需要定义一个“关于”Form的实例 Dim fAbout As New formAbout() '显示他 fAbout.Show() End Sub
Private Sub mFont_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mFont.Click If FontDialog1.ShowDialog() = DialogResult.OK Then rtbox.Font = FontDialog1.Font End If End Sub
Private Sub mUndo_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mUndo.Click rtbox.Undo() End Sub
Private Sub mCut_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mCut.Click rtbox.Cut() End Sub
Private Sub mCopy_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mCopy.Click rtbox.Copy() End Sub
Private Sub mPaste_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mPaste.Click rtbox.Paste() End Sub
Private Sub mClear_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mClear.Click rtbox.Clear() End Sub
Private Sub mSelectall_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mSelectall.Click rtbox.SelectAll() End Sub
Private Sub ToolBar1_ButtonClick(ByVal sender As System.Object, ByVal e As System.Windows.Forms.ToolBarButtonClickEventArgs) Handles ToolBar1.ButtonClick Select Case ToolBar1.Buttons.IndexOf(e.Button) Case 0 newfile() Case 1 openfile() Case 2 savefile() Case 5 printfile() Case 6 printpreview() Case 9 Panel1.Visible = True Case 12 rtbox.Cut() Case 13 rtbox.Copy() Case 14 rtbox.Paste() Case 15 rtbox.Undo()
End Select End Sub
Private Sub mPrint_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mPrint.Click printfile() End Sub
Private Sub comboxFont_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles comboxFont.SelectedIndexChanged SetFontFamily(rtbox, comboxFont.Text) End Sub
Private Sub comboxSize_SelectedIndexChanged(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles comboxSize.SelectedIndexChanged SetFontSize(rtbox, comboxSize.SelectedItem) End Sub
Private Sub ToolBar2_ButtonClick(ByVal sender As System.Object, ByVal e As System.Windows.Forms.ToolBarButtonClickEventArgs) Handles ToolBar2.ButtonClick Select Case ToolBar2.Buttons.IndexOf(e.Button) Case 0 If tbbbold.Pushed = True Then AddFontStyle(rtbox, FontStyle.Bold) Else RemoveFontStyle(rtbox, FontStyle.Bold) End If
Case 1 If tbbi.Pushed = True Then AddFontStyle(rtbox, FontStyle.Italic) Else RemoveFontStyle(rtbox, FontStyle.Italic) End If
Case 2 If tbbu.Pushed = True Then AddFontStyle(rtbox, FontStyle.Underline) Else RemoveFontStyle(rtbox, FontStyle.Underline) End If
Case 3 ColorDialog1.ShowDialog() rtbox.ForeColor = ColorDialog1.Color
Case 6 rtbox.SelectionAlignment = HorizontalAlignment.Left tbbmiddle.Pushed = False tbbright.Pushed = False Case 7 rtbox.SelectionAlignment = HorizontalAlignment.Center tbbleft.Pushed = False tbbright.Pushed = False Case 8 rtbox.SelectionAlignment = HorizontalAlignment.Right tbbleft.Pushed = False tbbmiddle.Pushed = False
End Select
End Sub '******************************************** '菜单中的隐藏状态栏功能 Private Sub mStatusbar_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mStatusbar.Click If mStatusbar.Checked = True Then StatusBar1.Visible = False mStatusbar.Checked = False Else StatusBar1.Visible = True mStatusbar.Checked = True End If End Sub '******************************************** '状态栏的信息 Private Sub HandleSelect(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mStatusbar.Select, mAbout.Select, mClear.Select, mCopy.Select, mNew.Select, mCut.Select, mEdit.Select, mExit.Select, mFile.Select, mFind.Select, mFindnext.Select, mFont.Select, mHelp.Select, mHelptopics.Select, mOpen.Select, mPagesetup.Select, mPaste.Select, mPrint.Select, mPrintpreview.Select, mReplace.Select, mSave.Select, mSaveas.Select, mSelectall.Select, mStatusbar.Select, mUndo.Select, mView.Select Dim strText As String
If sender Is mStatusbar Then strText = "决定是否隐藏状态栏...." ElseIf sender Is mAbout Then strText = "您将看到我们开发小组的一些资料" ElseIf sender Is mClear Then strText = "清空所有内容！" ElseIf sender Is mExit Then strText = "退出程序！" ElseIf sender Is mNew Then strText = "新建一个文档，会提示保存。。。" ElseIf sender Is mCopy Then strText = "复制选中的内容" ElseIf sender Is mCut Then strText = "剪切制定的内容" ElseIf sender Is mEdit Then strText = "编辑菜单" ElseIf sender Is mFile Then strText = "文件菜单" ElseIf sender Is mFind Then strText = "显示查找面板。。" ElseIf sender Is mFindnext Then strText = "查找下一个" ElseIf sender Is mFont Then strText = "显示字体设置对话框" ElseIf sender Is mOpen Then strText = "打开菜单" ElseIf sender Is mEdit Then strText = "编辑菜单" ElseIf sender Is mPagesetup Then strText = "页面设置选项" ElseIf sender Is mEdit Then strText = "编辑菜单" '......... '........ '........
Else strText = String.Empty End If
WriteToStatusBar(strText) End Sub
Public Sub WriteToStatusBar(ByVal Text As String) StatusBar1.Text = Text End Sub
Private Sub MenuItem2_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles MenuItem2.Click ColorDialog1.ShowDialog() rtbox.ForeColor = ColorDialog1.Color End Sub '*********************************************************************************************** '下面是关于实现查找功能 Dim MyPos As Integer '先声明一个全局变量
Private Sub FindText(ByVal start As Integer) '创建findtext函数 Dim pos As Integer Dim target As String '获取用户输入的要查找的字符串 target = txtbox.Text pos = InStr(start, rtbox.Text, target) If pos > 0 Then '找到了匹配字符串 MyPos = pos rtbox.SelectionStart = MyPos - 1 '高亮显示 rtbox.SelectionLength = Len(txtbox.Text) rtbox.Focus() Else MsgBox("没找到！")
End If End Sub
Private Sub find_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles find.Click FindText(1) End Sub
Private Sub findnext_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles findnext.Click FindText(MyPos + 1) End Sub
Private Sub Button4_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles closepanel.Click Panel1.Visible = False End Sub
'************************************************************************************************************* '下面这段程序，用作拖拽“查找面板”使用 Dim dragging As Boolean Dim mousex As Integer Dim mousey As Integer Private Sub panel1_MouseDown(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Panel1.MouseDown If e.Button = MouseButtons.Left Then dragging = True mousex = -e.X mousey = -e.Y Dim clipleft As Integer = Me.PointToClient(MousePosition).X - Panel1.Location.X Dim cliptop As Integer = Me.PointToClient(MousePosition).Y - Panel1.Location.Y Dim clipwidth As Integer = Me.ClientSize.Width - (Panel1.Width - clipleft) Dim clipheight As Integer = Me.ClientSize.Height - (Panel1.Height - cliptop) Cursor.Clip = Me.RectangleToScreen(New Rectangle(clipleft, cliptop, clipwidth, clipheight)) Panel1.Invalidate() End If End Sub
Private Sub panel1_MouseMove(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Panel1.MouseMove If dragging Then '移动控件到新的位置 Dim MPosition As New Point() MPosition = Me.PointToClient(MousePosition) MPosition.Offset(mousex, mousey) '确实控件不能离开主窗口 Panel1.Location = MPosition End If End Sub
Private Sub panel1_MouseUp(ByVal sender As Object, ByVal e As System.Windows.Forms.MouseEventArgs) Handles Panel1.MouseUp If dragging Then '结束拖拽 dragging = False Cursor.Clip = Nothing Panel1.Invalidate() End If End Sub '****************************************************************************************************************
Private Sub replace_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mpreplace.Click rtbox.Text = rtbox.Text.Replace(txtbox.Text, rpbox.Text) End Sub
Private Sub mFind_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mFind.Click Panel1.Visible = True
End Sub
Private Sub mFindnext_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mFindnext.Click FindText(MyPos + 1) End Sub
Private Sub mReplace_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mReplace.Click rtbox.Text = rtbox.Text.Replace(txtbox.Text, rpbox.Text) End SubEnd Class
'完。
