VB案例教学11级.doc

VB案例教学11级案例一：简易计算器设计案例二：电子相册设计案例三：文本编辑器设计案例四：速算24游戏案例五：动画时钟设计案例一：简易计算器设计一、界面设计属性设置对象类型名称（Name）属性名属性值说明窗体Form1Caption简易计算器文本框Text1Text空命令按钮Command1Caption1Command2Caption2Command3Caption3Command4Caption4Command5Caption5Command6Caption6Command7Caption7Command8Caption8Command9Caption9Command10Caption0Command11Caption.Command12Caption=Command13Caption+Command14Caption-Command15Caption*Command16Caption/Command17CaptionBackSpaceCommand18Caption清除Command19Caption关闭二、代码设计Dim choice As StringDim current As DoubleDim prev As DoubleDim flag As Boolean输入小数点Private Sub command11_Click() If Text1.Text = Then Text1.Text = 0. Else Text1.Text = Text1.Text & . End IfEnd Sub计算结果Private Sub command12_Click() If choice = + Then current = prev + current Text1.Text = current ElseIf choice = - Then current = prev - current Text1.Text = current ElseIf choice = * Then current = prev * current Text1.Text = current ElseIf choice = / And current 0 Then current = prev / current Text1.Text = current Else MsgBox 除数不能为零, , 出错 End IfEnd Sub退格Private Sub command17_Click()Text1.Text = Left(Text1.Text, Len(Text1.Text) - 1)End Sub清除Private Sub command18_Click()Text1.Text = prev = 0 current = 0End Sub退出程序Private Sub command19_Click() Unload Form1 EndEnd Sub输入数值Private Sub Command1_Click()Text1.Text = Text1.Text & 1 current = Val(Text1.Text)End SubPrivate Sub Command2_Click()Text1.Text = Text1.Text & 2 current = Val(Text1.Text)End SubPrivate Sub Command3_Click()Text1.Text = Text1.Text & 3 current = Val(Text1.Text)End SubPrivate Sub Command4_Click()Text1.Text = Text1.Text & 4 current = Val(Text1.Text)End SubPrivate Sub Command5_Click()Text1.Text = Text1.Text & 5 current = Val(Text1.Text)End SubPrivate Sub Command6_Click()Text1.Text = Text1.Text & 6 current = Val(Text1.Text)End SubPrivate Sub Command7_Click()Text1.Text = Text1.Text & 8 current = Val(Text1.Text)End SubPrivate Sub Command8_Click()Text1.Text = Text1.Text & 8 current = Val(Text1.Text)End SubPrivate Sub Command9_Click()Text1.Text = Text1.Text & 9 current = Val(Text1.Text)End SubPrivate Sub Command10_Click()Text1.Text = Text1.Text & 0 current = Val(Text1.Text)End Sub加载窗体时进行初始化设计Private Sub Form_Load() Form1.Width = 4700 Text1.Text = prev = 0 current = 0 Text1.SetFocus Text1.Locked = TrueEnd Sub相减Private Sub command14_Click() Text1.Text = choice = - prev = currentEnd Sub相加Private Sub command13_Click() Text1.Text = choice = + prev = currentEnd Sub相乘Private Sub command15_Click() Text1.Text = choice = * prev = currentEnd Sub相除Private Sub command16_Click() Text1.Text = choice = / prev = currentEnd Sub*改进设计(使用控件数组)一、界面设计属性设置对象类型名称（Name）属性名属性值说明窗体Form1Caption简易计算器文本框Text1Text空命令按钮Command1Caption1Index 1Command1Caption2Index 2Command1Caption3Index 3Command1Caption4Index 4Command1Caption5Index 5Command1Caption6Index 6Command1Caption7Index 7Command1Caption8Index 8Command1Caption9Index 9Command1 Caption0Index 0PointCaption.equalCaption=Command13Caption+Index 0Command13Caption-Index 1Command13Caption*Index 2Command13Caption/Index 3Command17CaptionBackSpaceCommand18Caption清除Command19Caption关闭二、代码设计Dim choice As IntegerDim current As DoubleDim prev As DoubleDim flag As Boolean输入运算符号Private Sub Command13_Click(Index As Integer) Text1.Text = choice = Index prev = currentEnd Sub加载窗体时进行初始化设计Private Sub Form_Load() Form1.Width = 4700 Text1.Text = prev = 0 current = 0 Text1.SetFocus Text1.Locked = TrueEnd Sub清除Private Sub ac_Click() Text1.Text = prev = 0 current = 0End Sub输入数值Private Sub Command1_Click(Index As Integer) Text1.Text = Text1.Text & Command1(Index).Caption current = Val(Text1.Text)End Sub输入小数点Private Sub point_Click() If Text1.Text = Then Text1.Text = 0. Else Text1.Text = Text1.Text & . End IfEnd Sub退格Private Sub BackSpace_Click()Text1.Text = Left(Text1.Text, Len(Text1.Text) - 1)End Sub计算结果Private Sub equal_Click() Select Case choice Case 0: current = prev + current Case 1: current = prev - current Case 2: current = prev * current Case 3: If choice = / And current 0 Then current = prev / current Text1.Text = current Else MsgBox 除数不能为零, , 出错 End If End Select Text1.Text = currentEnd Sub退出程序Private Sub exit_Click() Unload Form1 EndEnd Sub案例二：电子相册设计一、界面设计二、代码设计Option ExplicitPrivate opened As BooleanPrivate Sub Command1_Click(Index As Integer)If Not opened Then Exit Sub Select Case Index Case 0 第一幅 File1.ListIndex = 0 Case 1 前一幅 If File1.ListIndex = 0 Then Exit Sub File1.ListIndex = File1.ListIndex - 1 Case 2 下一幅 If File1.ListIndex = File1.ListCount - 1 Then Exit Sub File1.ListIndex = File1.ListIndex + 1 Case 3 最后一幅 File1.ListIndex = File1.ListCount - 1 End Select Image1.Picture = LoadPicture(File1.FileName) StatusBar1.Panels(1).Text = 共 & File1.ListCount & 张，第 & File1.ListIndex + 1 & 张 StatusBar1.Panels(2).Text = File1.Path Call Change_EnabledEnd SubPrivate Sub Command2_Click()If Timer1.Enabled Then Command2.Picture = LoadPicture(App.Path & play.ico) Else Command2.Picture = LoadPicture(App.Path & pause.ico) End If Timer1.Enabled = Not Timer1.EnabledEnd SubPrivate Sub Command3_Click() EndEnd SubPrivate Sub Dir1_Change() ChDir Dir1.Path File1.Path = Dir1.Path StatusBar1.Panels(2).Text = File1.PathEnd SubPrivate Sub Drive1_Change()ChDir Dir1.PathDir1.Path = Drive1.DriveEnd SubPrivate Sub Form_Load() If File1.ListCount 0 Then File1.ListIndex = 0 Image1.Picture = LoadPicture(File1.FileName) opened = True Else Image1.Picture = LoadPicture opened = False End If StatusBar1.Panels(1).Text = 共 & File1.ListCount & 张，第 & File1.ListIndex + 1 & 张 StatusBar1.Panels(2).Text = File1.Path If File1.ListCount 0 Then Command1(2).Enabled = True Command1(3).Enabled = True Command2.Enabled = True Timer1.Enabled = False End IfEnd SubPrivate Sub File1_Click() Image1.Picture = LoadPicture(File1.FileName) StatusBar1.Panels(1).Text = 共 & File1.ListCount & 张，第 & File1.ListIndex + 1 & 张End SubPrivate Sub Timer1_Timer() If Not opened Then Exit Sub If File1.ListIndex = File1.ListCount - 1 Then File1.ListIndex = 0 Else File1.ListIndex = File1.ListIndex + 1 End If Image1.Picture = LoadPicture(File1.FileName) StatusBar1.Panels(1).Text = 共 & File1.ListCount & 张，第 & File1.ListIndex + 1 & 张 Call Change_EnabledEnd SubPrivate Sub Change_Enabled() If File1.ListIndex = 0 Then Command1(0).Enabled = False Command1(1).Enabled = False Command1(2).Enabled = True Command1(3).Enabled = True ElseIf File1.ListIndex = File1.ListCount - 1 Then Command1(0).Enabled = True Command1(1).Enabled = True Command1(2).Enabled = False Command1(3).Enabled = False Else Command1(0).Enabled = True Command1(1).Enabled = True Command1(2).Enabled = True Command1(3).Enabled = True End IfEnd Sub案例三：文本编辑器设计一、界面设计二、程序代码设计1.主窗体 frmEdit.frmOption ExplicitDim Modified As BooleanDim filename As StringDim findstr As StringDim findpos As IntegerPrivate Declare Function SendMessage Lib user32 Alias SendMessageA (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As LongPrivate Const EM_UNDO = &HC7Const EM_GETSEL = &HB0Const EM_LINEFROMCHAR = &HC9Const EM_LINEINDEX = &HBBPublic Sub GetCaretPos(ByVal TextHwnd As Long, LineNo As Long, ColNo As Long)Dim i As Long, j As LongDim lParam As Long, wParam As LongDim k As Long首先向文本框传递EM_GETSEL消息以获取从起始位置到光标所在位置的字符数i = SendMessage(TextHwnd, EM_GETSEL, wParam, lParam)j = i / 2 16再向文本框传递EM_LINEFROMCHAR消息根据获得的字符数确定光标以获取所在行数LineNo = SendMessage(TextHwnd, EM_LINEFROMCHAR, j, 0)LineNo = LineNo + 1向文本框传递EM_LINEINDEX消息以获取所在列数k = SendMessage(TextHwnd, EM_LINEINDEX, -1, 0)ColNo = j - k + 1End SubPrivate Sub Form_Load() Dim i As Integer Dim LineNo As Long, ColNo As Long Call GetCaretPos(RichTextBox1.hwnd, LineNo, ColNo) StatusBar1.Panels(2).Text = LineNo & 行 & ColNo & 列 For i = 0 To Printer.FontCount - 1 comFont.AddItem Printer.Fonts(i) Next screen.Fonts Printer.FontSize comSize.AddItem 8 comSize.AddItem 10 comSize.AddItem 12 comSize.AddItem 16 comSize.AddItem 18 comSize.AddItem 22 comSize.AddItem 28 comSize.AddItem 36 comSize.AddItem 48End SubPrivate Sub Form_Activate() comFont.Text = 宋体 comSize.Text = 10End SubPrivate Sub Form_Resize()RichTextBox1.Left = 0RichTextBox1.Top = CoolBar1.HeightRichTextBox1.Width = frmEdit.ScaleWidthRichTextBox1.Top = CoolBar1.Height RichTextBox1.Height = frmEdit.ScaleHeight - CoolBar1.HeightEnd SubPrivate Sub Form_Unload(Cancel As Integer) Dim i As Integer If Modified Then i = MsgBox(文件尚未保存，退出之前是否保存？, vbYesNoCancel + vbInformation) If i = 6 Then If filename = Then CommonDialog1.ShowSave filename = CommonDialog1.filename End If RichTextBox1.SaveFile filename, 0 Else If i = 2 Then Cancel = 1 End If End If End IfEnd SubPrivate Sub mnuNew_Click() Dim i As Integer If Modified Then i = MsgBox(当前文件尚未保存，是否保存？, vbYesNoCancel + vbInformation) If i = 6 Then If filename = Then CommonDialog1.ShowSave filename = CommonDialog1.filename End If RichTextBox1.SaveFile filename, 0 Else If i = 2 Then Exit Sub End If End If End If RichTextBox1.TextRTF = filename = frmEdit.Caption = 文本编辑器：（新建文件） Modified = FalseEnd SubPrivate Sub mnuOpen_Click() Dim i As Integer If Modified Then i = MsgBox(当前文件尚未保存，是否保存？, vbYesNoCancel + vbInformation) If i = 6 Then If filename = Then CommonDialog1.ShowSave filename = CommonDialog1.filename End If RichTextBox1.SaveFile filename, 0 Else If i = 2 Then Exit Sub End If End If End If CommonDialog1.ShowOpen filename = CommonDialog1.filename RichTextBox1.LoadFile (filename) Modified = False frmEdit.Caption = 文本编辑器： & CommonDialog1.FileTitle End SubPrivate Sub mnuSave_Click() If filename = Then CommonDialog1.ShowSave filename = CommonDialog1.filename End If RichTextBox1.SaveFile filename, 0 frmEdit.Caption = 文本编辑器： & CommonDialog1.FileTitle Modified = False End SubPrivate Sub mnuSaveAs_Click() CommonDialog1.ShowSave If filename Then filename = CommonDialog1.filename RichTextBox1.SaveFile filename, 0 frmEdit.Caption = 文本编辑器： & CommonDialog1.FileTitle Modified = False End IfEnd SubPrivate Sub mnuExit_Click() Unload MeEnd SubPrivate Sub mnuCut_Click() Clipboard.SetText RichTextBox1.SelRTF, vbCFRTF RichTextBox1.SelRTF = End SubPrivate Sub mnuCopy_Click() Clipboard.SetText RichTextBox1.SelRTF, vbCFRTFEnd SubPrivate Sub mnuPaste_Click() If Clipboard.GetFormat(vbCFRTF) Then RichTextBox1.SelRTF = Clipboard.GetText(vbCFRTF) ElseIf Clipboard.GetFormat(vbCFText) Then RichTextBox1.SelRTF = Clipboard.GetText(vbCFText) End IfEnd SubPrivate Sub Find_Click() findstr = InputBox(请输入要查找的字符串：, 输入, RichTextBox1.SelText) If Len(findstr) 0 Then RichTextBox1.find findstr, 0 findpos = RichTextBox1.SelStart + 1 findN.Enabled = True End IfEnd SubPrivate Sub findN_Click() If Len(findstr) 0 Then RichTextBox1.find findstr, findpos findpos = RichTextBox1.SelStart + 1 findN.Enabled = True End IfEnd SubPrivate Sub Replace_Click()frmFindReplace.FindnReplace RichTextBox1End SubPrivate Sub selectall_Click() 选中所有内容 RichTextBox1.SelStart = 0 RichTextBox1.SelLength = Len(RichTextBox1.TextRTF)End SubPrivate Sub undo_Click() 向窗口发送ctrl+z键，自动执行撤消操作 SendKeys ZDim i As Integeri = SendMessage(RichTextBox1.hwnd, EM_UNDO, 0, 0)End SubPrivate Sub mnuForeColor_Click() CommonDialog1.ShowColor RichTextBox1.SelColor = CommonDialog1.ColorEnd SubPrivate Sub mnuBackColor_Click() CommonDialog1.ShowColor RichTextBox1.BackColor = CommonDialog1.ColorEnd SubPrivate Sub mnuFont_Click() CommonDialog1.Flags = 3 CommonDialog1.ShowFont RichTextBox1.Font.Size = CommonDialog1.FontSize RichTextBox1.Font.Name = CommonDialog1.FontNameEnd SubPrivate Sub mnuAbout_Click() frmAbout.Show 1, MeEnd SubPrivate Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button) Select Case Button.Key Case new mnuNew_Click Case open mnuOpen_Click Case save mnuSave_Click Case cut mnuCut_Click Case copy mnuCopy_Click Case paste mnuPaste_Click Case help mnuAbout_Click End SelectEnd SubPrivate Sub comFont_Click() RichTextBox1.SelFontName = Trim(comFont.Text) RichTextBox1.SetFocusEnd SubPrivate Sub comSize_click() RichTextBox1.SelFontSize = Val(comSize.Text) RichTextBox1.SetFocusEnd SubPrivate Sub comSize_KeyPress(KeyAscii As Integer) If KeyAscii = 13 Then RichTextBox1.SelFontSize = Val(comSize.Text)End SubPrivate Sub Toolbar2_ButtonClick(ByVal Button As MSComctlLib.Button) Select Case Button.Key Case bold RichTextBox1.SelBold = Button.Value Case italic RichTextBox1.SelItalic = Button.Value Case underline RichTextBox1.SelUnderline = Button.Value Case strike RichTextBox1.SelStrikeThru = Button.Value Case left RichTextBox1.SelAlignment = 0 Case center RichTextBox1.SelAlignment = 2 Case right RichTextBox1.SelAlignment = 1 Case fontcolor CommonDialog1.ShowColor RichTextBox1.SelColor = CommonDialog1.Color End SelectEnd SubPrivate Sub RichTextBox1_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 在状态栏显示光标位置 Dim LineNo As Long, ColNo As Long Call GetCaretPos(RichTextBox1.hwnd, LineNo, ColNo) StatusBar1.Panels(2).Text = LineNo & 行 & ColNo & 列End SubPrivate Sub RichTextBox1_KeyUp(KeyCode As Integer, Shift As Integer)在状态栏显示光标位置 Dim LineNo As Long, ColNo As Long Call GetCaretPos(RichTextBox1.hwnd, LineNo, ColNo) StatusBar1.Panels(2).Text = LineNo & 行 & ColNo & 列End SubPrivate Sub RichTextBox1_Change() Modified = TrueEnd SubPrivate Sub CmdBold_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)把状态栏的第一个Panels中的Text属性设为转化为粗体的帮助信息staSample.Panels(1).Text = staSample.Panels(1).Text = 转化为粗体End Sub2.查找替换窗体 frmFindReplace.frmOption Explicit This variable is used for making the algorithm generic.Dim txtClient As RichTextBox This method is the public interface to SnR functionality.Public Sub FindnReplace(ByRef Tb As RichTextBox) Set txtClient = Tb Me.Show , txtClient.ParentEnd SubPrivate Sub cmdReplace_Click() Dim CaseSense As Integer Dim SourceText As String Dim SourceTextCopy As String Dim Cnt As Integer Check for the case sensitivity options If (chkCaseSense.Value = vbChecked) Then CaseSense = 0 Else CaseSense = 1 End If One contains the original text and another contains replaced (updated) one. Used to check whether a replacement was done or not. SourceText = txtClient.Text SourceTextCopy = SourceText If Len(SourceText) = 0 Then Exit Sub End If On Error GoTo ErrHandler Dim SearchTermLen As Integer Dim FndPos As Integer SearchTermLen = Len(txtSearchTerm.Text) Search from the begining of the document. Cnt = 1 This is endless loop (terminated on a conditi