增强型记事本设计文档

增强型记事本设计文档 ——【?SOLOMON?】胡振菊 【编者按】 界面要求:程序应具有以下友好的界面:1，操作简便，2，外观漂亮 任何程序在编程或制作前应有详细设计文档，保证有了后再写代码。必须利用面向对象的原则将项目细分，使其构件化，并将构件作为小的项目看待。 不得使用长于两个月周期的项目。应何产品，都应当有长度约为一周的短期目标。每一目标应当是可以运行且能够看到结果的目标。如果要实现某一功能，则一定要使其完善，即，送给用户"夹生的"，不如只给用户"做熟的"。时刻应当注意，产品是一个整体，即只要有任何一个构件不足，则会毁了本产品。在用法不确定时，查看帮助。编译通过时，应作边界值查错。动用编程时，应先理顺思路。(好的思路可能使代码更少，且效率更高) 当一个逻辑单元的程序写好时，及时加上详细的注解，写明逻辑流程。应当考虑该设计的实现手段易出错的程度如何,如果易出错，则应当找出更好的不易出错的手段再开始写程序。 查错原则: 1， 在编程时，当程序发现错误，应当立即改错。现在就改，以避免程序完成时遗漏未改的错误。 2， 发现错误时，应当找出从错误的源头再修改。(对此，应当摒弃"工作量太大了"的思想) 3， 当代码有错时，绝不可以猜测错在哪里。试图碰运气改正它。必须停下来思考已发现的错误，从而判断是否别的地方有相关的错误还没有暴露出来。思考如何更易发现错误，如何避免此类错误。 【程序步骤】 〖主窗体frmMain〗 步骤一:绘制主窗体界面 新建一个EXE，将其Caption属性改为“增强型记事本”，点击Icon属性给它找个合适的Icon图标。 单击菜单“工程”-“部件”，在弹出的“部件”对话框里找到Microsoft RichText Box 6.0和公共对话框Microsoft Common Dialog 6.0(SP6)并选中它们，单击“确定”按钮。这时左边的工具栏上出现了我们刚才新添的两 个控件了。在窗体上绘制RichTextBox和CommonDialog。设置RichTextBox的Appearance属性为 0-rtfFlat,BorderStyle属性为0-NoBorder，设置属性MultiLine=True,ScrollBars=3,DisableNoScroll=False, RightMargin=0。添加38个Image控件，用于装载菜单图标。三个时钟控件:一个用于控制“展示”窗体 的消失时间，一个用于控制“动态窗体标题显示”，一个用于控制“自动保存”的触发时间。 步骤二:编辑菜单 按Ctrl+E调出菜单编辑器，做如下几个菜单: 一. 文件菜单: 文件(第一层) mnuFile 新建(第二层) mnuNew 打开(第二层) mnuOpen 最近打开(第二层) mnuRecentOpen 当前打开文件1(第三层) mnuRecentFile 当前打开文件2(第三层) mnuRecentFile 当前打开文件3(第三层) mnuRecentFile 当前打开文件4(第三层) mnuRecentFile 当前打开文件5(第三层) mnuRecentFile 当前打开文件6(第三层) mnuRecentFile 保存(第二层) mnuSave 另存为(第二层) mnuSaveAs - (第二层) None (分隔线) 打印(第二层) mnuPrint - (第二层) None1 (分隔线) 退出(第二层) mnuExit 二. 编辑菜单: 编辑(第一层) mnuEdit 撤消(第二层) mnuUndo - (第二层) None2 复制(第二层) mnuCopy 剪切(第二层) mnuCut 粘贴(第二层) mnuPaste 选择性粘贴(第二层) mnuSelectPaste 删除(第二层) mnuDelect - (第二层) None3 查找(第二层) mnuFind 查找下一个(第二层) mnuFindNext 替换(第二层) mnuReplace - (第二层) None4 (分隔线) 转到(第二层) mnuGoto 全选(第二层) mnuSelecAll 三. 格式菜单: 格式(第一层) mnuFormat 窗体形态(第二层) mnuXingTai 窗体透明(第三层) mnuTouMing 窗体不透明(第三层) mnuNoTouMing 背景颜色(第二层) mnuColor - (第二层) None5 (分隔线) 字体设置(第二层) mnuFont 对齐方式(第二层) mnuAlign 左对齐(第三层) mnuLeft 居中对齐(第三层) mnuCenter 右对齐(第三层) mnuRight 上标下标(第二层) mnuUpDown 上标(第三层) mnuUpLabel 下标(第三层) mnuDownLabel 文件信息(第二层) mnuInfo - (第二层) None6 (分隔线) 时间/日期(第二层) mnuTimeDate 四. 外部程序菜单: 外部程序(第一层) mnuExter 系统计算器(第二层) mnuCalc 自制计算器(第二层) mnuDIYCalc - (第二层) None7(分隔线) Media Player(第二层) mnuMplayer 控制光驱 (第二层) mnuCDROM - (第二层) None8(分隔线) 插入图片(第二层) mnuInsert 图像处理(第二层) mnuPicEdit - (第二层) None9(分隔线) ASCII码对照(第二层) mnuAscii 字符映射表(第二层) mnuCharmap 五笔字根表(第二层) mnuWB86 五(选项菜单: 查看 (第一层) mnuOption 自动保存(第二层) mnuAutoSave - (第二层) None10(分隔线) 插入对象(第二层) mnuInsertOLE - (第二层) None11(分隔线) 项目符号(第二层) mnuItemFlag 自动换行(第二层) mnuAutoLine 六(帮助菜单: 帮助 (第一层) 记事本帮助(第二层) mnuNoteHelp 关于记事本(第二层) mnuAbout - (第二层) None12(分隔线) 展示窗口(第二层) mnuSplash (注:各菜单项的快捷键请自行设置) 步骤三:设计窗体(9个)，两个标准模块 程序代码: '************************************************************************************************************************ ' 设计者:胡振菊(SOLOMON 武汉)04617228 ' 设计时间:二??五年十一月十六日 ' 之后反复修改，增删数次 ' 终稿时间:二??五年十二月三十日 ' 设计单位:江西省东华理工学院计通系计算机软件04级 ' 设计目的:学习，作为课程设计内容 '************************************************************************************************************************ Option Explicit Private Declare Function GetMenu Lib "user32" (ByVal hwnd As Long) As Long Private Declare Function GetSubMenu Lib "user32" (ByVal hMenu As Long, ByVal nPos As Long) As Long Private Declare Function SetMenuItemBitmaps Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long, ByVal hBitmapUnchecked As Long, ByVal hBitmapChecked As Long) As Long Const myflag = cdlOFNExtensionDifferent '上述部分是图标菜单的声明段 Private Declare Function CDdoor Lib "winmm.dll" Alias "mciSendStringA" (ByVal lpstrCommand As String, ByVal lpstrReturnString As String, ByVal uReturnLength As Long, ByVal hwndCallback As Long) As Long 'CDOpen用来标示光驱开与关的状态 Dim CDOpen As Boolean '使用SetLayeredWindowAttributes函数，可以实现半透明窗体 Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long '其中hwnd是透明窗体的句柄，crKey为颜色值，bAlpha是透明度，取值范围是[0,255]，dwFlags是透 明方式，可以取两个值:当取值为LWA_ALPHA时，crKey参数无效，bAlpha参数有效;当取值为 LWA_COLORKEY时，bAlpha参数有效而窗体中的所有颜色为crKey的地方将变为透明 Private Const WS_EX_LAYERED = &H80000 Private Const GWL_EXSTYLE = (-20) Private Const LWA_ALPHA = &H2& Private Const LWA_COLORKEY = &H1& '上面是制作半透明窗体的声明 '得到/显示文本行数的API函数声明 Private Declare Function SendMessageLong Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long Const EM_GETLINECOUNT = &HBA '以下为“让窗体标体动态显示”的变量声明 Dim words As String '定义一个变量，用来存储窗体的标题 Dim intN As Integer '定义一个存储字符串个数的变量 Dim txtword As String '定义一个变量，用来存储标题中的单个字符 Dim frmCaptionlenth As Integer '定义此变量用来存储窗体标题的长度 '以下为文件处理所需变量,使用VB6.0新引入的“文件系统对象FileSystemObject” Dim rtfContent As String '此变量接受RichTextBox1.text文本内容 Dim result As VbMsgBoxResult '此变量为对象浏览器中常量，接受MsgBox返回值 Dim fsObject As Object '创建一个文件系统对象型的变量 Dim fObject As File '定义一个文件型的对象变量 Dim tsObject As TextStream '定义一个文本流对象变量 Dim nextline, linesfromfile As String '定义接受文件行数和下一行的变量 Dim IsChange As Boolean '定义一个标示文本内容变化的变量 Dim Filename As String '定义打开保存的文件名 Private Sub mnuAscii_Click() '调用“ASCII对照表”窗体 Load frmAscii frmAscii.Show End Sub Private Sub mnuAutoSave_Click() '“自动保存”菜单 Dim setTime As String setTime = InputBox("请输入你要自动存盘的时间间隔(分钟):", "【?自动保存?】", "3") Timer3.Interval = Val(setTime) * 60 * 1000 '设置自动存盘的时间间隔为分钟 End Sub Private Sub mnuDIYCalc_Click() '调用“自制计算器”窗体 Load frmCalc frmCalc.Show End Sub Private Sub mnuEdit_Click() '没有选中文本内容时使相应的菜单项失效 If TypeOf Me.ActiveControl Is RichTextBox Then Me.mnuCut.Enabled = Me.ActiveControl.SelLength Me.mnuCopy.Enabled = Me.ActiveControl.SelLength Me.mnuDelect.Enabled = Me.ActiveControl.SelLength Me.mnuPaste = Clipboard.GetFormat(vbCFText) Else Me.mnuCut.Enabled = False Me.mnuCopy.Enabled = False Me.mnuPaste.Enabled = False Me.mnuDelect.Enabled = False End If If OLE1.PasteOK Then mnuSelectPaste.Enabled = True Else mnuSelectPaste.Enabled = False End If End Sub Private Sub mnuFind_Click() '“查找”菜单 mnuFindNext.Enabled = True If RichTextBox1.SelText <> "" Then frmFind.txtFind.text = RichTextBox1.SelText Else frmFind.txtFind.text = gFindString End If gFirstTime = True ' 设置公共变量在起始位置执行 If (gFindCase) Then ' 设置大小写复选框与公共变量匹配 frmFind.chkCase = 1 End If frmFind.Show ' 显示查找窗题 frmMain.RichTextBox1.SetFocus '当前文本编辑框获得焦点 End Sub Private Sub mnuFindNext_Click() '“查找下一个”菜单 If Len(gFindString) > 0 Then ' 如果公共变量不为空, 调用查找过程, 否则调用查找菜单 FindIt Else mnuFind_Click End If End Sub Private Sub mnuGoto_Click() '调用“转到”窗体 Load frmGoto frmGoto.Show End Sub Private Sub mnuInfo_Click() '“文件信息” Dim lineCount As Long, msg As String On Local Error Resume Next '得到/显示文本行数 lineCount = SendMessageLong(RichTextBox1.hwnd, EM_GETLINECOUNT, 0&, 0&) msg = "文本行数 : " & Format$(lineCount, "##,###") & " 行" Dim rtfText As String, temp As String, msg1 As String, msg2 As String, msg3 As String, msg4 As String, msg5 As String, filelong As String, filesize As String Dim i As Integer, EngNum As Integer, ChNum As Integer, SpaceNum As Integer, SignNum As Integer, NumberNum As Integer rtfText = RichTextBox1.text EngNum = 0 '英文字数 ChNum = 0 '中文字数 SpaceNum = 0 '空格 SignNum = 0 '标点符号 NumberNum = 0 '数字 For i = 1 To Len(rtfText) temp = Mid$(rtfText, i, 1) If Asc(temp) >= 65 And Asc(temp) <= 90 Or Asc(temp) >= 97 And Asc(temp) <= 122 Then EngNum = EngNum + 1 ElseIf Asc(temp) >= 48 And Asc(temp) <= 57 Then NumberNum = NumberNum + 1 ElseIf Asc(temp) = 32 Then SpaceNum = SpaceNum + 1 ElseIf Asc(temp) < 0 Then ChNum = ChNum + 1 Else SignNum = SignNum + 1 End If Next i msg1 = "英文字数 : " & CStr(EngNum) msg2 = "中文字数 : " & CStr(ChNum) msg3 = "空 格 : " & CStr(SpaceNum) msg4 = "标点符号 : " & CStr(SignNum) msg5 = "数 字 : " & CStr(NumberNum) filelong = EngNum + ChNum * 2 + SpaceNum + SignNum + NumberNum filesize = CStr(filelong / 1024) MsgBox msg1 & vbCrLf & msg2 & vbCrLf & msg3 & vbCrLf & msg4 & vbCrLf & msg5 & vbCrLf & msg & vbCrLf & "文件大小 : " & filesize + " KB", vbInformation, "当前文本统计" End Sub Private Sub mnuAbout_Click() '调用“关于”窗体 Load frmAbout frmAbout.Show End Sub Private Sub mnuCenter_Click() '居中 If mnuCenter.Checked = True Then mnuCenter.Checked = False mnuLeft.Checked = True mnuRight.Checked = True Else mnuCenter.Checked = True mnuLeft.Checked = False mnuRight.Checked = False End If RichTextBox1.SelAlignment = 2 '居中对齐 End Sub Private Sub mnuCharmap_Click() '调用外部程序“字符映射表” Shell "charmap.exe", vbNormalFocus End Sub Private Sub mnuColor_Click() '调用颜色对话框 Me.CommonDialog1.ShowColor Me.RichTextBox1.BackColor = Me.CommonDialog1.Color End Sub Private Sub mnuCopy_Click() '关于“复制”有两种实现方式 '第一种: 'Clipboard.SetText RichTextBox1.SelText '将选中的文本赋给剪贴板 '第二种: SendKeys "^{INSERT}" '模拟“Ctrl+Insert” End Sub Private Sub mnuCut_Click() '关于“剪切”有两种实现方式 '第一种: 'Clipboard.SetText RichTextBox1.SelText '将选中的文本赋给剪贴板,同时清空所选部分 'RichTextBox1.SelText = "" '第二种: SendKeys "+{DEL}" '模拟“Shift+Del” End Sub '利用API函数SendMessage在Richtextbox控件中插入图片 Private Sub mnuInsert_Click() CommonDialog1.DialogTitle = "【打开】请选择你要插入的图片" CommonDialog1.Filter = "图形文件 (*.jpg;*.bmp;*.gif;*.pcx)|*.jpg;*.bmp;*.gif;*.pcx" CommonDialog1.ShowOpen Filename = CommonDialog1.Filename Clipboard.Clear Clipboard.SetData LoadPicture(Filename) '也可以使用“Sendkeys "^V"”发送键盘指令 SendMessage RichTextBox1.hwnd, &H302, 0, ByVal 0& End Sub Private Sub mnuInsertOLE_Click() '显示“插入对象”对话框 On Error Resume Next OLE1.InsertObjDlg '检查是否用 OLEType 属性创建一个对象。 If OLE1.OLEType = vbOLENone Then Exit Sub RichTextBox1.Visible = False OLE1.Move 0, 0 OLE1.Height = Me.Height OLE1.Width = Me.Width End Sub Private Sub mnuItemFlag_Click() '插入项目符号样式 mnuItemFlag.Checked = Not mnuItemFlag.Checked If mnuItemFlag.Checked = True Then RichTextBox1.SelBullet = True RichTextBox1.BulletIndent = 1 Else RichTextBox1.SelBullet = False End If End Sub Private Sub mnuRecentFile_Click(Index As Integer) ' 调用文件打开过程, 传递一个索引值到选定名称的文件 OpenFile (mnuRecentFile(Index).Caption) ' 更新文件菜单控件数组中的最近打开文件列表。 GetRecentFiles End Sub Private Sub mnuReplace_Click() '“替换”菜单 Load frmReplace frmReplace.Show '调用“替换”对话框 End Sub Private Sub mnuSelectPaste_Click() '“选择性粘贴” If OLE1.PasteOK Then OLE1.PasteSpecialDlg End Sub Private Sub mnuUpLabel_Click() '上标 OffsetRichText RichTextBox1, 1, 1, 2 mnuUpLabel.Checked = True mnuDownLabel.Checked = False End Sub Private Sub mnuDownLabel_Click() '下标 OffsetRichText RichTextBox1, 4, 1, -2 mnuDownLabel.Checked = True mnuUpLabel.Checked = False End Sub Private Sub mnuLeft_Click() '居左 If mnuLeft.Checked = True Then mnuLeft.Checked = False mnuRight.Checked = True mnuCenter.Checked = True Else mnuLeft.Checked = True mnuRight.Checked = False mnuCenter.Checked = False End If RichTextBox1.SelAlignment = 0 '左对齐 End Sub Private Sub mnuNoteHelp_Click() SendKeys "{F1}" '模拟键盘的F1键 End Sub '下面是制作不透明窗体的函数使用 Private Sub mnuNoTouMing_Click() Dim PreValue As Long Call SetWindowLong(Me.hwnd, GWL_EXSTYLE, PreValue) mnuNoTouMing.Checked = True mnuTouMing.Checked = False End Sub Private Sub mnuPaste_Click() '关于“粘贴”有两种实现方式: '第一种: 'RichTextBox1.SelText = Clipboard.GetText '将剪贴板中的内容贴至当前光标处 '第二种: SendKeys "+{INSERT}" ''模拟“Shift+Insert” End Sub Private Sub mnuDelect_Click() RichTextBox1.SelText = "" '将编辑区内容清空 End Sub Private Sub mnuExit_Click() If IsChange = True Then result = MsgBox("文本内容尚未存盘～是否存盘,", vbYesNo + vbExclamation + vbDefaultButton1, "存 盘提示～-【?SOLOMON?】") If result = vbNo Then End Else Call mnuSaveAs_File End If Else End End If End Sub Private Sub Form_Load() ChDir App.Path ' 总是将工作路径设置到包含此应用程序的路径 GetRecentFiles ' 对系统注册表并且设置最近菜单文件列表控件数组属性 gFindDirection = 1 ' 设置公共变量 gFindDirection ，它来决定FindIt 函数将搜索的方向 '动态显示窗体标题 words = Me.Caption '存储窗体的标题 Me.Caption = "" '将窗体标题清空 mnuFindNext.Enabled = False '程序启动时禁掉“查找下一个”菜单项 '文本框提示文字 RichTextBox1.ToolTipText = "欢迎使用SOLOMON用Visual Basic编写的增强型记事本，支持OLE拖放文 件至此打开～谢谢使用!" '控制光驱 CDOpen = False Call CDdoor("set CDAudio door closed", 0, 0, 0) '控制光驱 frmSplash.Show '展示产品信息窗体 '调用系统记事本帮助文件 App.HelpFile = "C:\WINDOWS\Help\notepad.chm" IsChange = False '文本框内容初始为没变化 '下面是制作半透明窗体的函数使用 Dim rtn As Long rtn = GetWindowLong(hwnd, GWL_EXSTYLE) rtn = rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, rtn SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA '下面部分是图标菜单的主程序 Dim mHandle As Long, lRet As Long, sHandle As Long, sHandle2 As Long '取得菜单的句柄并赋值给mHandle，接着取得mHandle句柄所指菜单的第一个弹出式菜单的句柄并赋值 给sHandle mHandle = GetMenu(hwnd) sHandle = GetSubMenu(mHandle, 0) '然后就为菜单项加入图标，这里把wFlags参数设为MF_BYPOSITION，也就是说使用菜单项的位置(从 序号,开始)来标示菜单项 lRet = SetMenuItemBitmaps(sHandle, 0, myflag, imgNew.Picture, imgNew.Picture) lRet = SetMenuItemBitmaps(sHandle, 1, myflag, imgOpen.Picture, imgOpen.Picture) lRet = SetMenuItemBitmaps(sHandle, 2, myflag, imgFind.Picture, imgFind.Picture) lRet = SetMenuItemBitmaps(sHandle, 3, myflag, imgSave.Picture, imgSave.Picture) lRet = SetMenuItemBitmaps(sHandle, 4, myflag, imgSave.Picture, imgSave.Picture) lRet = SetMenuItemBitmaps(sHandle, 6, myflag, imgPrint.Picture, imgPrint.Picture) lRet = SetMenuItemBitmaps(sHandle, 8, myflag, imgExit.Picture, imgExit.Picture) '取得mHandle句柄所指菜单的第二个弹出式菜单的句柄并赋值给sHandle sHandle = GetSubMenu(mHandle, 1) lRet = SetMenuItemBitmaps(sHandle, 0, myflag, imgUndo.Picture, imgUndo.Picture) lRet = SetMenuItemBitmaps(sHandle, 2, myflag, imgCut.Picture, imgCut.Picture) lRet = SetMenuItemBitmaps(sHandle, 3, myflag, imgCopy.Picture, imgCopy.Picture) lRet = SetMenuItemBitmaps(sHandle, 4, myflag, imgPaste.Picture, imgPaste.Picture) lRet = SetMenuItemBitmaps(sHandle, 5, myflag, imgPaste.Picture, imgPaste.Picture) lRet = SetMenuItemBitmaps(sHandle, 6, myflag, imgDel.Picture, imgDel.Picture) lRet = SetMenuItemBitmaps(sHandle, 8, myflag, imgFind.Picture, imgFind.Picture) lRet = SetMenuItemBitmaps(sHandle, 9, myflag, imgDigital.Picture, imgDigital.Picture) lRet = SetMenuItemBitmaps(sHandle, 10, myflag, imgAscii.Picture, imgAscii.Picture) lRet = SetMenuItemBitmaps(sHandle, 12, myflag, imgGoto.Picture, imgGoto.Picture) lRet = SetMenuItemBitmaps(sHandle, 13, myflag, imgAllSelect.Picture, imgAllSelect.Picture) '取得mHandle句柄所指菜单的第三个弹出式菜单的句柄并赋值给sHandle sHandle = GetSubMenu(mHandle, 2) lRet = SetMenuItemBitmaps(sHandle, 0, myflag, imgTouMing.Picture, imgTouMing.Picture) lRet = SetMenuItemBitmaps(sHandle, 1, myflag, imgColor.Picture, imgColor.Picture) lRet = SetMenuItemBitmaps(sHandle, 3, myflag, imgFont.Picture, imgFont.Picture) lRet = SetMenuItemBitmaps(sHandle, 4, myflag, imgAlign.Picture, imgAlign.Picture) lRet = SetMenuItemBitmaps(sHandle, 5, myflag, imgUpDown.Picture, imgUpDown.Picture) lRet = SetMenuItemBitmaps(sHandle, 6, myflag, imgInfo.Picture, imgInfo.Picture) lRet = SetMenuItemBitmaps(sHandle, 8, myflag, imgDate.Picture, imgDate.Picture) '取得sHandle句柄所指菜单的第一个次级菜单(次级菜单)的句柄并赋值给sHandle2 sHandle2 = GetSubMenu(sHandle, 4) '在次级菜单中加上图片 lRet = SetMenuItemBitmaps(sHandle2, 0, myflag, imgGou.Picture, imgLeft.Picture) lRet = SetMenuItemBitmaps(sHandle2, 1, myflag, imgGou.Picture, imgCenter.Picture) lRet = SetMenuItemBitmaps(sHandle2, 2, myflag, imgGou.Picture, imgRight.Picture) '取得mHandle句柄所指菜单的第四个弹出式菜单的句柄并赋值给sHandle sHandle = GetSubMenu(mHandle, 3) lRet = SetMenuItemBitmaps(sHandle, 0, myflag, imgCalc.Picture, imgCalc.Picture) lRet = SetMenuItemBitmaps(sHandle, 1, myflag, imgDigital.Picture, imgDigital.Picture) lRet = SetMenuItemBitmaps(sHandle, 3, myflag, imgMplayer.Picture, imgMplayer.Picture) lRet = SetMenuItemBitmaps(sHandle, 4, myflag, imgCDROM.Picture, imgCDROM.Picture) lRet = SetMenuItemBitmaps(sHandle, 6, myflag, imgInsert.Picture, imgInsert.Picture) lRet = SetMenuItemBitmaps(sHandle, 7, myflag, imgPicEdit.Picture, imgPicEdit.Picture) lRet = SetMenuItemBitmaps(sHandle, 9, myflag, imgAscii.Picture, imgAscii.Picture) lRet = SetMenuItemBitmaps(sHandle, 10, myflag, imgCharmap.Picture, imgCharmap.Picture) lRet = SetMenuItemBitmaps(sHandle, 11, myflag, imgWB86.Picture, imgWB86.Picture) '取得mHandle句柄所指菜单的第五个弹出式菜单的句柄并赋值给sHandle sHandle = GetSubMenu(mHandle, 4) lRet = SetMenuItemBitmaps(sHandle, 0, myflag, imgSave.Picture, imgSave.Picture) lRet = SetMenuItemBitmaps(sHandle, 2, myflag, imgAscii.Picture, imgAscii.Picture) '取得mHandle句柄所指菜单的第六个弹出式菜单的句柄并赋值给sHandle sHandle = GetSubMenu(mHandle, 5) lRet = SetMenuItemBitmaps(sHandle, 0, myflag, imgHelp.Picture, imgHelp.Picture) lRet = SetMenuItemBitmaps(sHandle, 1, myflag, imgAbout.Picture, imgAbout.Picture) lRet = SetMenuItemBitmaps(sHandle, 3, myflag, imgSplash.Picture, imgSplash.Picture) End Sub '控制实现化学符号的上下标 Private Sub OffsetRichText(box As RichTextBox, start As Integer, length As Integer, offset As Integer) 'box指RichTextBox控件;start指作为上下标的 '字符的起始位置;length指上下标字符的长度; 'offset指上标还是下标，大于0上标;小于0下标。 start = box.SelStart length = box.SelLength box.SelFontSize = box.Font.Size - Abs(offset) box.SelCharOffset = ScaleY(offset, vbPoints, vbTwips) '返回或设置一个值，由它确定 RichTextBox 控件中 的文本是出现在基线上(正常状态)，还是作为上标出现在基线之上或作为下标出现在基线之下。此属性在 设计时无效 box.SelStart = 0 box.SelLength = 0 End Sub Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer) If IsChange = True Then result = MsgBox("文本内容尚未存盘～是否存盘,", vbYesNoCancel + vbExclamation + vbDefaultButton1, "存盘提示～-【?SOLOMON?】") If result = vbYes Then Call mnuSaveAs_File ElseIf result = vbCancel Then Cancel = 1 End If Else End End If End Sub Private Sub Form_Resize() '窗体大小改变时RichTextBox文本框也随着改变 RichTextBox1.Height = ScaleHeight RichTextBox1.Width = ScaleWidth End Sub Private Sub mnuFont_Click() '调用字体对话框 CommonDialog1.Flags = cdlCFBoth + cdlCFEffects CommonDialog1.ShowFont '要改变 RichTextBox 控件中的字体特性，可以使用SelFontName、SelFontSize 和 SelFontColor 属性 With RichTextBox1 .SelFontName = CommonDialog1.FontName .SelFontSize = CommonDialog1.FontSize .SelBold = CommonDialog1.FontBold .SelItalic = CommonDialog1.FontItalic .SelStrikeThru = CommonDialog1.FontStrikethru .SelUnderline = CommonDialog1.FontUnderline .SelColor = CommonDialog1.Color End With End Sub Private Sub mnuNew_Click() '“新建”菜单 Timer2.Enabled = True '启动“动态窗体标题显示”计时器 If IsChange = True Then result = MsgBox("文本内容尚未存盘～是否存盘,", vbYesNoCancel + vbExclamation + vbDefaultButton1, "存盘提示～-【?SOLOMON?】") If result = vbNo Then RichTextBox1.text = "" IsChange = False ElseIf result = vbCancel Then Exit Sub Else Call mnuSaveAs_File End If Else RichTextBox1.text = "" IsChange = False End If End Sub Private Sub mnuOpen_Click() '“打开”菜单 If IsChange = True Then '如果当前内容已改变而未存盘要求打开新文件时，执行如下代码 result = MsgBox("文本内容尚未存盘～是否存盘,", vbYesNoCancel + vbExclamation + vbDefaultButton1, "存盘提示～") If result = vbNo Then '用户选择了“否”按钮 Call Open_File ElseIf result = vbCancel Then '用户选择了“取消”按钮则退出过程 Exit Sub Else Call mnuSaveAs_File End If Else Call Open_File End If End Sub Private Sub mnuPrint_Click() 'RichTextBox自带的打印功能，调用Microsoft Office Document Imaging打印文档软件 '使用 Microsoft Office Document Imaging 可查看、管理、读取和识别图像文档和传真中的文本。 On Error GoTo xx RichTextBox1.SelPrint Printer.hDC Exit Sub xx: result = MsgBox("对不起～你的电脑没有安装打印机，无法打印～", vbCritical + vbOKOnly, "打印报错") If result = vbOK Then Resume Next End Sub Private Sub mnuRight_Click() '居右 If mnuRight.Checked = True Then mnuRight.Checked = False mnuLeft.Checked = True mnuCenter.Checked = True Else mnuRight.Checked = True mnuLeft.Checked = False mnuCenter.Checked = False End If RichTextBox1.SelAlignment = 1 '右对齐 End Sub Private Sub mnuSaveAs_Click() '“另存为”菜单选项 Call mnuSaveAs_File If Filename = "" Then Exit Sub End If IsChange = False End Sub Private Sub mnuSave_Click() '“保存”菜单选项 If Filename <> "" Then Open Filename For Output As #1 Print #1, RichTextBox1.text Close #1 ElseIf IsChange = False Then Exit Sub Else Call mnuSaveAs_File End If IsChange = False End Sub Private Sub mnuAllSelect_Click() '“全选”菜单选项 RichTextBox1.SelStart = 0 '首选将要选择的开始处置为文章开始 RichTextBox1.SelLength = Len(RichTextBox1.text) '测试文章有多长，然后作为选择的长度 RichTextBox1.SetFocus '将设置的选择长度做为选择的文本。 End Sub Private Sub mnuSplash_Click() '调用“展示”窗体 Timer1.Enabled = False Load frmSplash frmSplash.Show End Sub '下面是制作半透明窗体的函数使用 Private Sub mnuTouMing_Click() Dim rtn As Long rtn = GetWindowLong(hwnd, GWL_EXSTYLE) rtn = rtn Or WS_EX_LAYERED SetWindowLong hwnd, GWL_EXSTYLE, rtn SetLayeredWindowAttributes hwnd, 0, 200, LWA_ALPHA mnuTouMing.Checked = True mnuNoTouMing.Checked = False End Sub Private Sub mnuUndo_Click() '撤消操作 'Sendkeys模拟键盘发送ALT+Backspace指令到控制器 '这是Window's Undo的组合键 SendKeys "%{BS}" End Sub Private Sub mnuMplayer_Click() '调用媒体播放器 Shell "C:\Program Files\Windows Media Player\mplayer2.exe", vbNormalFocus End Sub Private Sub mnuPicEdit_Click() '调用系统的“画图”软件 Shell "mspaint.exe", vbNormalFocus End Sub Private Sub mnuCalc_Click() '调用系统的“计算器” Shell "calc.exe", vbNormalFocus End Sub '控制“自动换行”功能 Private Sub mnuAutoLine_Click() '开关控制True和False mnuAutoLine.Checked = Not mnuAutoLine.Checked If mnuAutoLine.Checked = True Then RichTextBox1.RightMargin = 0 '自动换行 Else RichTextBox1.RightMargin = 10000 '不自动换行 End If End Sub Private Sub mnuWB86_Click() '调用“五笔字根表”窗体 Load frmWB86 frmWB86.Show End Sub Private Sub OLE1_Click() '在OLE控件与文本控件间切换 OLE1.Close RichTextBox1.Visible = True End Sub Private Sub RichTextBox1_Change() IsChange = True '当前内容已经被更改了。 End Sub Private Sub mnuTimeDate_Click() '插入“时间/日期” Dim weeknumber As Integer, weekCh As String weeknumber = Weekday(Date, vbSunday) Select Case weeknumber Case 1 weekCh = " 星期天 " Case 2 weekCh = " 星期一 " Case 3 weekCh = " 星期二 " Case 4 weekCh = " 星期三 " Case 5 weekCh = " 星期四 " Case 6 weekCh = " 星期五 " Case 7 weekCh = " 星期六 " End Select Me.RichTextBox1.SelText = Me.RichTextBox1.SelText + FormatDateTime(Now(), vbLongDate) + weekCh + CStr(Time) End Sub '注释:RichTextBox控件自带有打开保存文件的数据成员()， '可以不必涉及到课本第15章数据文件的操作，但它有个问题就是保存文本后，用系统自带的记事本打开它所保存的中文文本时，会偶尔出现乱码。 '权衡再三，还是决定使用数据文件与RichTextBox控件自带方法兼并的操作方法。 'RichTextBox控件的打开文件成员为LoadFile 'RichTextBox控件的保存文件成员为SaveFile 'RichTextBox控件的打印文件成员为SelPrint Private Sub mnuSaveAs_File() Dim strSaveFileName As String CommonDialog1.DialogTitle = "【另存为】--若要保存所设定的格式，请选择RTF格式重命名保存" CommonDialog1.Filter = "纯文本TXT(*.txt)|*.txt|丰富文本RTF(*.rtf)|*.rtf|网页文件(*.htm;*.html)|*.htm;*.html|Word文档(*.doc)|*.doc" '设置保存对话框中文件类型下拉菜单中的文件类型 CommonDialog1.Filename = "" CommonDialog1.Flags = cdlOFNOverwritePrompt '设置当文件已存在时，给出信息提示 CommonDialog1.ShowSave '显示保存公共对话框 Filename = CommonDialog1.Filename '保存所选路径和文件名 strSaveFileName = Filename If strSaveFileName <> "" Then SaveFileAs (strSaveFileName) ' 更新文件菜单控件数组中的最近打开文件列表。 UpdateFileMenu (strSaveFileName) If Filename = "" Then Exit Sub ElseIf CommonDialog1.FilterIndex = 2 Then RichTextBox1.SaveFile Filename Else rtfContent = RichTextBox1.text Set fsObject = CreateObject("scripting.filesystemobject") '定义文件系统对象 Open Filename For Output As #1 '建立文件 Close #1 Set fObject = fsObject.GetFile(Filename) Set tsObject = fObject.OpenAsTextStream(ForWriting) tsObject.Write rtfContent '对文件进行写操作 IsChange = False End If End Sub Private Sub Open_File() CommonDialog1.Filter = "纯文本TXT(*.txt)|*.txt|丰富文本RTF(*.rtf)|*.rtf|网页文件(*.htm;*.html)|*.htm;*.html|Word文档(*.doc)|*.doc|所有文件(*.*)|*.*" '设置保存对话框中文件类型下拉菜单中的文件类型 CommonDialog1.DialogTitle = "【打开】--请选择相应格式的文件打开" CommonDialog1.Filename = "" CommonDialog1.ShowOpen Filename = CommonDialog1.Filename frmMain.Caption = Filename + "?增强型记事本--SOLOMON?" If Filename = "" Then Exit Sub Timer2.Enabled = True ElseIf CommonDialog1.FilterIndex = 2 Then RichTextBox1.LoadFile (Filename) Else Set fsObject = CreateObject("scripting.filesystemobject") Open Filename For Input As #1 '打开新的文件读到当前文本输入框中 Do Until EOF(1) Line Input #1, nextline linesfromfile = linesfromfile + nextline + Chr(13) + Chr(10) Loop Close #1 RichTextBox1.text = linesfromfile linesfromfile = "" IsChange = False '设置当前编辑状态 Timer2.Enabled = False '禁掉“动态窗体标题显示”计时器 End If IsChange = False UpdateFileMenu (Filename) End Sub Private Sub mnuCDROM_Click() On Error Resume Next '如果关闭则打开，并且按钮做相应变化 If CDOpen = False Then Call CDdoor("set CDAudio door open", 0, 0, 0) CDOpen = True mnuCDROM.Caption = "关闭光驱(&C)" Else '否则关闭 Call CDdoor("set CDAudio door closed", 0, 0, 0) CDOpen = False mnuCDROM.Caption = "打开光驱(&C)" End If End Sub '此段代码是为解决采用Ctrl+V快捷键，导致粘贴两次的情况。 Private Sub RichTextBox1_KeyDown(KeyCode As Integer, Shift As Integer) If KeyCode = vbKeyV And Shift = 2 Then KeyCode = 0 Call mnuPaste_Click End If '此段代码是为解决采用Ctrl+Z快捷键，导致不能实现键盘热键撤消功能的情况。 If KeyCode = vbKeyZ And Shift = 2 Then Call mnuUndo_Click End If End Sub '调出右键菜单，这里调用的是“编辑”菜单 Private Sub RichTextBox1_MouseDown(Button As Integer, Shift As Integer, x As Single, y As Single) If Button = 2 Then frmMain.PopupMenu mnuEdit End If End Sub '下面为OLE拖放操作的代码 '完成拖动时 Private Sub RichTextBox1_OLEDragDrop(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single) If Data.GetFormat(vbCFText) Then RichTextBox1.text = Data.GetData(vbCFText) '当数据类型为文本时 End If If Data.GetFormat(vbCFFiles) Then '当数据类型为文件时 Dim vfn For Each vfn In Data.Files dropfile RichTextBox1, vfn '调用子函数，在文本框中打开文件 Next vfn End If End Sub '在文本框中打开文件时的子函数 Sub dropfile(ByVal text As RichTextBox, ByVal strfn$) Dim ifile As Integer ifile = FreeFile Open strfn For Input Access Read Lock Read Write As #ifile Dim str$, strline$ While Not EOF(ifile) And Len(str) <= 32000 Line Input #ifile, strline$ If str <> "" Then str = str & vbCrLf str = str & strline Wend Close #ifile RichTextBox1.SelStart = Len(text) RichTextBox1.SelLength = 0 RichTextBox1.SelText = str End Sub '当拖放经过文本框时 Private Sub RichTextBox1_OLEDragOver(Data As RichTextLib.DataObject, Effect As Long, Button As Integer, Shift As Integer, x As Single, y As Single, State As Integer) If Data.GetFormat(vbCFText) Or Data.GetFormat(vbCFFiles) Then Effect = vbDropEffectCopy And Effect Exit Sub End If Effect = vbDropEffectNone End Sub Private Sub Timer1_Timer() Dim oncetime As Integer oncetime = oncetime - 1 '为展示窗体的启动计时 If oncetime <= 50 Then Unload frmSplash End If End Sub '以下计时器为窗体标题动态显示计时 Private Sub Timer2_Timer() frmCaptionlenth = Len(words) '取得窗体标题长度 txtword = Left(words, intN) '取得窗体标题左边intN个字符 Me.Caption = txtword '动态设置窗体的标题 intN = intN + 1 If intN > frmCaptionlenth Then '窗体标题显示完毕，循环动态显示窗体标题 intN = 0 End If End Sub Private Sub Timer3_Timer() '可以用如下语句调用文件菜单的保存命令，显示文件保存对话框 'SendKeys "%(FS)", True '但是它调用的是当前活动窗口的“保存”命令， '当本程序处于非活动状态时，会进行其它程序的自动保存 '因而还是使用Call调用本程序的“保存”命令 Call mnuSave_Click End Sub 〖“展示”窗体frmSplash〗 界面设计:一个Image控件，8个标签Label，如图，背景为透明，窗体BorderStyle属性值为0-None 程序代码: Option Explicit „形成“菱形”窗体的API函数声明 Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Type POINTAPI x As Long y As Long End Type Private Sub Form_Load() Dim ap(4) As POINTAPI Dim hx As Integer Dim hy As Integer Dim reRgn As Long hy = Me.Height \ (2 * Screen.TwipsPerPixelY) hx = Me.Width \ (2 * Screen.TwipsPerPixelX) ap(0).x = 0: ap(0).y = hy ap(1).x = hx: ap(1).y = 0 ap(2).x = Me.Width \ Screen.TwipsPerPixelX: ap(2).y = hy ap(3).x = hx: ap(3).y = Me.Height \ Screen.TwipsPerPixelY ap(4) = ap(0) reRgn = CreatePolygonRgn(ap(0), 5, 1) SetWindowRgn Me.hWnd, reRgn, True '使窗体始终保持在最上层 SetWindowPos hWnd, HWND_TOPMOST, 200, 200, 490, 288, SWP_SHOWWINDOW End Sub Private Sub Frame1_Click() Unload Me End Sub 〖“关于”窗体frmAbout〗 界面设计:一个命令按钮CommandButton，6个标签Label，2个直线控件Line，一个图片框PictureBox。 这个“关于”对话框也可在“工程”—“添加窗体”中“新建”一个“关于”对话框。 程序代码: Option Explicit '下面为调用超链接的API函数声明 Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hWnd As Long, ByVal lpOperation As String, ByVal lpFile As String, ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long Private Sub cmdOK_Click() Unload Me End Sub Private Sub Label1_Click() Call ShellExecute(frmAbout.hWnd, "Open", "mailto:hmilo029@yahoo.com.cn", "", App.Path, 1) End Sub Private Sub Label2_Click() Call ShellExecute(frmAbout.hWnd, "open", "", vbNullString, vbNullString, &H0) End Sub 〖“替换”窗体frmReplace〗 界面设计:五个命令按钮CommandButton，一个CheckBox控件，三个TextBox控件，三个标签Label 程序代码: Option Explicit Dim position As Long '查找位置的变量 Dim bMore As Boolean Private Sub CmdShow_Click() If bMore Then CmdShow.Caption = "中文数字大写同步显示>>" Me.Height = 1965 Else CmdShow.Caption = "中文数字大写同步隐藏<<" Me.Height = 2475 End If bMore = Not bMore End Sub Private Sub DlgFindText_Change() TxtNumToCh.text = CChinese(DlgFindText.text) End Sub '下面为“全部替换功能”的代码 Private Sub DlgReplaceAll_Click() Dim lngLen As Long Dim lngStart As Long Do If lngStart = 0 Then lngStart = 1 Else lngStart = frmMain.RichTextBox1.SelStart lngStart = lngStart + frmMain.RichTextBox1.SelLength End If lngLen = Len(frmMain.RichTextBox1.text) Loop While FindString(DlgFindText.text, DlgReplaceText.text, lngStart, lngLen) End Sub Function FindString(strFind As String, strReplace As String, lngStart As Long, lngEnd As Long) As Boolean Dim lngPos As Long With frmMain.RichTextBox1 lngPos = InStr(lngStart, .text, strFind, 1) If lngPos = 0 Then FindString = False Else If Not ((lngPos + Len(strFind)) > lngEnd) Then FindString = True .SelStart = lngPos - 1 .SelLength = Len(strFind) If strReplace <> "" Then 'Replace It .SelText = strReplace End If End If End If End With End Function '上面为“全部替换功能”的代码 Private Sub DlgFindAgainButton_Click() Dim compare As Integer '再次查找命令按钮处理代码 If DlgCheck1.Value = 1 Then '只是比查找代码少一句position=0 compare = vbBinaryCompare Else compare = vbTextCompare End If '查找字符串 position = InStr(position + 1, frmMain.RichTextBox1.text, DlgFindText.text, compare) If position > 0 Then DlgReplaceButton.Enabled = True frmMain.RichTextBox1.SelStart = position - 1 frmMain.RichTextBox1.SelLength = Len(DlgFindText.text) frmDialog.Show frmMain.SetFocus Else MsgBox "对不起～没有找到你要查找的“" & frmDialog.DlgFindText & "”～", vbExclamation DlgReplaceButton.Enabled = False End If End Sub Private Sub DlgFindButton_Click() Dim compare As Integer '查找命令按钮处理代码 position = 0 If DlgCheck1.Value = 1 Then compare = vbBinaryCompare Else compare = vbTextCompare End If '查找字符串 position = InStr(position + 1, frmMain.RichTextBox1.text, DlgFindText.text, compare) If position > 0 Then DlgReplaceButton.Enabled = True frmMain.RichTextBox1.SelStart = position - 1 frmMain.RichTextBox1.SelLength = Len(DlgFindText.text) frmDialog.Show frmMain.SetFocus Else MsgBox "对不起～没有找到你要查找的“" & frmDialog.DlgFindText & "”～", vbExclamation DlgReplaceButton.Enabled = False End If End Sub Private Sub DlgReplaceButton_Click() frmMain.RichTextBox1.SelText = DlgReplaceText.text '将选中内容改为"替换为"内容 Call DlgFindAgainButton_Click End Sub Private Sub Form_Load() DlgFindText.ToolTipText = "请输入你要查找的字符" DlgReplaceText.ToolTipText = "请输入你要替换的字符" Me.Caption = Me.Caption + CStr(Now) '设置窗体所在位置和总在最前 SetWindowPos hWnd, HWND_TOPMOST, 350, 400, 340, 130, SWP_SHOWWINDOW '窗体的位置Left:350; Top:400; Width:380; Height:170 End Sub 〖“查找”窗体frmFind〗 界面设计:一个标签Label，一个框架Frame，一个复选框CheckBox，两个单选框OptionBox，两个命令按钮CommandButton，一个文本框TextBox Option Explicit Private Sub chkCase_Click() gFindCase = chkCase.Value ' 指定一个值到公共变量 End Sub Private Sub cmdCancel_Click() gFindString = txtFind.text ' 保存此值到公共变量 gFindCase = chkCase.Value Unload frmFind ' 卸载查找对话框 End Sub Private Sub cmdFind_Click() gFindString = txtFind.text ' 指定一个文本字符串到公共变量 FindIt End Sub Private Sub Form_Load() cmdFind.Enabled = False ' 还没有要查找的文本,禁用查找按钮 optDirection(gFindDirection).Value = 1 ' 设置选向按钮值 Me.Caption = Me.Caption + CStr(Now) '设置窗体所在位置和总在最前 SetWindowPos hwnd, HWND_TOPMOST, 320, 400, 380, 120, SWP_SHOWWINDOW '窗体的位置Left: 320; Top:400; Width:400; Height:130 End Sub Private Sub optDirection_Click(Index As Integer) gFindDirection = Index ' 指定一个值到公共变量 End Sub Private Sub txtFind_Change() gFirstTime = True ' 设置公共变量 ' 如果文本框为空，禁用查找按钮 If txtFind.text = "" Then cmdFind.Enabled = False Else cmdFind.Enabled = True End If End Sub 〖“ASCII码对照表”窗体frmAscii〗 界面设计:一个标签Label，一个图像框Image 没有程序代码。 〖“转到”窗体frmGoto〗 界面设计:两个命令按钮CommandButton，一个标签Label，一个文本框TextBox 程序代码: Option Explicit Private Sub cmdCancel_Click() Unload Me End Sub Private Sub Form_Activate() Text1.ToolTipText = "在此处键入想要光标移动到的行号，行号从文档的顶部开始沿着左侧页边距开始计算。" Me.Text1.SetFocus cmdOK.Enabled = False End Sub Private Sub cmdOK_Click() Dim txtVal As Integer txtVal = Val(Me.Text1.text) If txtVal < 0 Or txtVal > TextLines(frmMain.RichTextBox1) Then MsgBox "对不起，你要转到的行数超过范围～", vbOKOnly + vbExclamation, "增强型记事本程序--SOLOMON - 跳行" Exit Sub Else frmMain.RichTextBox1.SelStart = TextLineBegin(frmMain.RichTextBox1, Val(Me.Text1.text) - 1) Unload frmGoto End If End Sub Private Function TextLines(TB As Control) TextLines = SendMessage(TB.hwnd, EM_GETLINECOUNT, 0, 0&) End Function Private Function TextLineBegin(TB As Control, LineNum As Integer) TextLineBegin = SendMessage(TB.hwnd, EM_LINEINDEX, LineNum, 0&) End Function Private Sub Text1_Change() ' 如果文本框为空，禁用确定按钮 If Me.Text1.text = "" Then cmdOK.Enabled = False Else cmdOK.Enabled = True End If End Sub 〖“五笔字根表”窗体frmWB86〗 界面设计:无控件，将图片设为窗体背景。BorderStyle为0-None 〖“自制计算器”窗体frmCalc〗 界面设计:添加34个CommandButton控件:0-9这10个按钮作为一个控件数组; 运算符 (+, -, x, /, \,Mod,%,X^Y,=)作为一个控件数组;其它的按钮各自编写代码。当然也可组成一个控件数组。 8个标签:4个标签作为提示名称:显示屏、提示屏、数字分组、中文大写;4个标签作为显示 标签BorderStyle属性为,，Alignment属性为,。窗体MaxButton属性为False。 程序代码: '****************************************** '本计算器变量的命名与控件使用方式参照了 'Microsoft Corporation公司设计的VB版计算器 '样板，并借鉴另行添加了些许功能。 '****************************************** Option Explicit Dim Op1, Op2 ' 预先输入操作数 Dim DecimalFlag As Boolean ' 确认小数点是否存在 Dim NumOps As Integer ' 操作数个数 Dim LastInput ' 指示上一次按键事件的类型 Dim OpFlag ' 指示未完成的操作 Dim TempReadout Const PI = 3.14159265358979 '定义圆周率常量 ' C (取消) 按钮的 Click 事件过程 ' 重新设置显示并初始化变量。 Private Sub Cancel_Click() Readout = Format(0, "0.") Op1 = 0 Op2 = 0 Form_Load End Sub ' CE (取消输入) 按钮的 Click 事件过程。 Private Sub CancelEntry_Click() Readout = Format(0, "0.") DecimalFlag = False LastInput = "CE" End Sub Private Sub cmdSqr_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Readout = Format(Sqr(Op1), "0.") End Sub Private Sub cmdBackspace_Click() Dim wordlen As Integer wordlen = Len(Readout) Readout = Left(Readout, wordlen - 1) If Len(Readout) = 0 Then Readout = "0." End Sub Private Sub cmdPI_Click() Readout = Format(3.14159265358979, "0.00000000000000") End Sub Private Sub cmdSquare_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Readout = Format(Op1 ^ 2, "0.") End Sub Private Sub cmdCube_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Readout = Format(Op1 ^ 3, "0.") End Sub Private Sub cmdExp_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Readout = Format(Exp(Op1), "0.") End Sub Private Sub cmdLog_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Readout = Format(Log(Op1), "0.") End Sub Private Sub cmdSin_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Op1 = Op1 * PI / 180 Readout = Format(Sin(Op1), "0.####") End Sub Private Sub cmdCos_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Op1 = Op1 * (PI / 180) Readout = Format(Cos(Op1), "0.####") End Sub Private Sub cmdTan_Click() Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 Readout = Format(Tan(Op1), "0.####") End Sub Private Sub cmdFactorial_Click() Dim i As Integer, sum As Long sum = 1 For i = 1 To Val(Readout) sum = sum * i Next i Readout = Format(sum, "0.") End Sub Private Sub cmdDaoshu_Click() Dim res As Double Op1 = CSng(Readout.Caption) '将输入的数转换成单精度型的 res = 1 / Op1 Readout = Format(res, "0.#####") End Sub ' 小数点 (.) 按钮的 Click 事件过程 ' 如果上一次按键为运算符，初始化 readout 为 "0."; ' 否则显示时追加一个小数点。 Private Sub Decimal_Click() If LastInput = "NEG" Then Readout = Format(0, "-0.") ElseIf LastInput <> "NUMS" Then Readout = Format(0, "0.") End If DecimalFlag = True LastInput = "NUMS" End Sub ' 窗体的初始化过程 ' 设置所有变量为其初始值。 Private Sub Form_Load() DecimalFlag = False NumOps = 0 LastInput = "NONE" OpFlag = " " Readout = Format(0, "0.") 'Decimal.Caption = Format(0, ".") End Sub ' 数字键 (0-9) 的 Click 事件过程 ' 向显示中的数追加新数。 Private Sub Number_Click(Index As Integer) If LastInput <> "NUMS" Then Readout = Format(0, ".") DecimalFlag = False End If If DecimalFlag Then Readout = Readout + Number(Index).Caption Else Readout = Left(Readout, InStr(Readout, Format(0, ".")) - 1) + Number(Index).Caption + Format(0, ".") End If If LastInput = "NEG" Then Readout = "-" & Readout LastInput = "NUMS" If Val(Readout) > 0 Then lblTiShiScr.Caption = lblTiShiScr.Caption & Number(Index).Caption End If End Sub ' 运算符 (+, -, x, /, =) 的 Click 事件过程 ' 如果接下来的按键是数字键，增加 NumOps。 ' 如果有一个操作数，则设置 Op1。 ' 如果有两个操作数，则将 Op1 设置为 Op1 与 ' 当前输入字符串的运算结果，并显示结果。 Private Sub Operator_Click(Index As Integer) TempReadout = Readout If LastInput = "NUMS" Then NumOps = NumOps + 1 End If Select Case NumOps Case 0 If Operator(Index).Caption = "-" And LastInput <> "NEG" Then Readout = "-" & Readout LastInput = "NEG" End If Case 1 Op1 = Readout If Operator(Index).Caption = "-" And LastInput <> "NUMS" And OpFlag <> "=" Then Readout = "-" LastInput = "NEG" End If Case 2 Op2 = TempReadout Select Case OpFlag Case "+" Op1 = CDbl(Op1) + CDbl(Op2) Case "-" Op1 = CDbl(Op1) - CDbl(Op2) Case "*" Op1 = CDbl(Op1) * CDbl(Op2) Case "/" If Op2 = 0 Then MsgBox "除数不能为零", 48, "计算器" Else Op1 = CDbl(Op1) / CDbl(Op2) End If Case "\" Op1 = CDbl(Op1) \ CDbl(Op2) Case "Mod" Op1 = CDbl(Op1) Mod CDbl(Op2) Case "X^Y" Op1 = CDbl(Op1) ^ CDbl(Op2) Case "=" Op1 = CDbl(Op2) Case "%" Op1 = CDbl(Op1) * CDbl(Op2) End Select Readout = Format(Op1, "0.") NumOps = 1 End Select If LastInput <> "NEG" Then LastInput = "OPS" OpFlag = Operator(Index).Caption End If If Val(Readout) > 0 Then lblTiShiScr.Caption = lblTiShiScr.Caption & OpFlag End If End Sub ' 百分比键 (%) 的 Click 事件过程 ' 计算并显示第一个操作数的百分数。 Private Sub Percent_Click() Readout = Readout / 100 LastInput = "Ops" OpFlag = "%" NumOps = NumOps + 1 DecimalFlag = True End Sub Private Sub Readout_Change() Dim ReadChg As String lblFormatScr.Caption = Format(Readout, "#,###,###.#####") ReadChg = Format(Readout, "###") lblChScr.Caption = CChinese(ReadChg) End Sub 〖标准模块fNotePlus〗 Option Explicit Public gFindString As String ' 保存搜索文本 Public gFindCase As Integer ' 区分大小写标志 Public gFindDirection As Integer ' 搜索方向标志 Public gCurPos As Integer ' 保存当前光标位置 Public gFirstTime As Integer ' 起始位置 Public Const ThisApp = "SOLOMONNote" ' 注册表 App 常量。 Public Const ThisKey = "Recent Files" ' 注册表 Key 常量。 Sub FindIt() Dim intStart As Integer Dim intPos As Integer Dim strFindString As String Dim strSourceString As String Dim strMsg As String Dim intResponse As Integer Dim intOffset As Integer ' 根据当前光标位置设置偏移量变量 If (gCurPos = frmMain.RichTextBox1.SelStart) Then intOffset = 1 Else intOffset = 0 End If ' 为起始位置读公有变量 If gFirstTime Then intOffset = 0 ' 给搜索起始位置赋值 intStart = frmMain.RichTextBox1.SelStart + intOffset ' 如果不匹配大小写，将字符串转换成大写 If gFindCase Then strFindString = gFindString strSourceString = frmMain.RichTextBox1.text Else strFindString = UCase(gFindString) strSourceString = UCase(frmMain.RichTextBox1.text) End If ' 搜索字符串 If gFindDirection = 1 Then intPos = InStr(intStart + 1, strSourceString, strFindString) Else For intPos = intStart - 1 To 0 Step -1 If intPos = 0 Then Exit For If Mid(strSourceString, intPos, Len(strFindString)) = strFindString Then Exit For Next End If ' 如果找到了字符串则 If intPos Then frmMain.RichTextBox1.SelStart = intPos - 1 frmMain.RichTextBox1.SelLength = Len(strFindString) Else strMsg = "对不起，没有找到要查找的 " & Chr(34) & gFindString & Chr(34) intResponse = MsgBox(strMsg, vbExclamation, App.Title) End If ' 重新设置公有变量 gCurPos = frmMain.RichTextBox1.SelStart gFirstTime = False End Sub Sub GetRecentFiles() ' 使用GetAllSettings 函数从 Windows 注册表中返回值的数组 ' 在这种情况下，注册表包含最近打开的文件列表。使用 SaveSetting 语句记下最近使用的文件名 ' 该语句在 WriteRecentFiles 过程中使用 Dim i As Integer Dim varFiles As Variant ' 存储返回的数组的变量 ' 用 GetAllSettings 语句从注册表中返回最近使用的文件 ' ThisApp 和 ThisKey是模块中定义的常数 If GetSetting(ThisApp, ThisKey, "RecentFile1") = Empty Then Exit Sub varFiles = GetAllSettings(ThisApp, ThisKey) For i = 0 To UBound(varFiles, 1) frmMain.mnuRecentFile(i).Caption = varFiles(i, 1) frmMain.mnuRecentFile(i).Visible = True Next i End Sub Sub WriteRecentFiles(OpenFileName) ' 使用 SaveSettings 语句将最近打开的文件名写入系统注册表。 ' SaveSettings 语句要求三个参数其中两个存储为常数并在本模块内定义。 ' GetRecentFiles 过程中使用 GetAllSettings 函数来检索这个过程中存储的文件名。 Dim i As Integer Dim strFile As String Dim strKey As String ' 将文件 当前文件1(RecentFile1) 复制给 当前文件2(RecentFile2)，等等 For i = 5 To 0 Step -1 strKey = "RecentFile" & i strFile = GetSetting(ThisApp, ThisKey, strKey) If strFile <> "" Then strKey = "RecentFile" & (i + 1) SaveSetting ThisApp, ThisKey, strKey, strFile End If Next i ' 将正在打开的文件写到最近使用文件列表的第一项 SaveSetting ThisApp, ThisKey, "RecentFile1", OpenFileName End Sub Sub UpdateFileMenu(Filename) Dim intRetVal As Integer ' 检查打开的文件是否已经存在于文件菜单控件数组。 intRetVal = OnRecentFilesList(Filename) If Not intRetVal Then ' 写打开的文件到注册表。 WriteRecentFiles (Filename) End If ' 更新文件菜单控件数组中的最近打开文件列表。 GetRecentFiles End Sub Function OnRecentFilesList(Filename) As Integer Dim i ' 当前文件列表的索引值 For i = 0 To 5 If frmMain.mnuRecentFile(i).Caption = Filename Then OnRecentFilesList = True Exit Function End If Next i OnRecentFilesList = False End Function Sub SaveFileAs(Filename) On Error Resume Next Dim strContents As String Open Filename For Output As #1 ' 打开文件 ' 把记事本的内容放入一个变量。 strContents = frmMain.RichTextBox1.text ' 写变量内容到一个已保存的文件。 Print #1, strContents Close #1 If Err Then MsgBox Error, 48, App.Title Else frmMain.Caption = Filename End If End Sub Sub OpenFile(Filename) frmMain.Timer2.Enabled = False Dim fIndex As Integer On Error Resume Next Open Filename For Input As #1 ' 打开选定的文件 If Err Then MsgBox "不能打开文件: " + Filename Exit Sub End If ' 更改窗体的标题并且显示新的文本 frmMain.Caption = UCase(Filename) frmMain.RichTextBox1.text = StrConv(InputB(LOF(1), 1), vbUnicode) Close #1 End Sub 〖标准模块mNotePlus〗 Option Explicit '保持窗体总在最前面的函数声明 Public Declare Function SetWindowPos Lib "user32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long Public Const HWND_TOPMOST = -1 Public Const SWP_NOMOVE = &H2 Public Const SWP_NOSIZE = &H1 Public Const SWP_SHOWWINDOW = &H40 '利用API函数SendMessage在Richtextbox控件中插入图片 (类似MSN的聊天表情) Public Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long Public Const EM_GETLINECOUNT = &HBA Public Const EM_LINEINDEX = &HBB '注明:这个算法取自现成，不是本人写出的 '将阿拉伯数字转成中文数字 Public Function CChinese(StrEng As String) As String If Not IsNumeric(StrEng) Or StrEng Like "*.*" Or StrEng Like "*-*" Then CChinese = "": Exit Function End If Dim intLen As Integer, intCounter As Integer Dim strCh As String, strTempCh As String Dim strSeqCh1 As String, strSeqCh2 As String Dim strNumToCh As String strNumToCh = "零壹贰叁肆伍陆柒捌玖" strSeqCh1 = " 拾佰仟 拾佰仟 拾佰仟 拾佰仟" strSeqCh2 = " 万亿兆" StrEng = CStr(CDec(StrEng)) intLen = Len(StrEng) For intCounter = 1 To intLen strTempCh = Mid(strNumToCh, Val(Mid(StrEng, intCounter, 1)) + 1, 1) If strTempCh = "零" And intLen <> 1 Then If Mid(StrEng, intCounter + 1, 1) = "0" Or (intLen - intCounter + 1) Mod 4 = 1 Then strTempCh = "" End If Else strTempCh = strTempCh & Trim(Mid(strSeqCh1, intLen - intCounter + 1, 1)) End If If (intLen - intCounter + 1) Mod 4 = 1 Then strTempCh = strTempCh & Mid(strSeqCh2, (intLen - intCounter + 1) \ 4 + 1, 1) If intCounter > 3 Then If Mid(StrEng, intCounter - 3, 4) = "0000" Then strTempCh = Left(strTempCh, Len(strTempCh) - 1) End If End If strCh = strCh & Trim(strTempCh) Next CChinese = strCh End Function 心系媛情 二??五年十一月十六日 之后反复修改，增删数次 终稿时间:二??五年十二月三十日