form1.frm

记事本(模仿微软记事本),欢迎大家使用

Private Sub D_Click()
End Sub



Private Sub Form_Load()

   Text1.Text = ""
   Text1.Left = 0
   Text1.Top = 550
      Text1.Width = Form1.ScaleWidth
       Text1.Height = Form1.ScaleHeight
        mnucut.Enabled = False
         mnucopy.Enabled = False
          mnudelete.Enabled = False
          mnuselectall.Enabled = False
           mnupaste.Enabled = True
            mnuleft.Checked = True
End Sub

Private Sub Form_Resize()
  '如果窗体不处于最小化text1状态，改变text1大小以适应窗体大小变化
    If Form1.WindowState <> 1 Then
        Text1.Width = Form1.Width - 120
        If Form1.Height < 1200 Then
            Form1.Height = 1200
        End If
        Text1.Height = Form1.Height - 1350
        End If
End Sub





Private Sub Form_Unload(Cancel As Integer)
Dim msg As Integer
If Text1.Text <> neirong Then
      msg = MsgBox(" 内容已被修改,是否保存文件", 48 + vbYesNoCancel, "提示")
    If msg = vbYes Then
    
         On Error GoTo Err
  cmndlg1.DialogTitle = "保存文件"
    cmndlg1.Filter = "文本文件|*.txt"
    cmndlg1.CancelError = True
    cmndlg1.ShowSave
      Open cmndlg1.FileName For Output As #1
       Print #1, Text1.Text
       Close #1
Err:
     If Err.Number = cdlCancel Then
      Cancel = True
      End If
    ElseIf msg = vbNo Then
        End
    ElseIf msg = vbCancel Then
        Cancel = True
    End If
    Else
    End
    End If
End Sub

Private Sub lijinxing_Click()
Form2.Visible = True
End Sub

Private Sub mnucopy_Click()  '复制  利用SetText 方法,将选中的文本放入剪贴板上
  Clipboard.SetText Text1.SelText

End Sub

Private Sub mnucut_Click() '剪切
   Clipboard.SetText Text1.SelText
     Text1.SelText = ""
End Sub

Private Sub mnudelete_Click()    '删除
Text1.SelText = ""
End Sub

Private Sub mnuedit_Click() '编辑 菜单项代码
                             ' 如果文本框中没有选中的内容,则剪切\复制\删除和粘贴菜单无效,否则有效
  If Text1.SelLength <> 0 Then
     mnucut.Enabled = True
     mnucopy.Enabled = True
     mnudelete.Enabled = True
     mnupaste.Enabled = True
  Else
     mnucut.Enabled = False
     mnucopy.Enabled = False
     mnudelete.Enabled = False
     
  End If

End Sub

Private Sub mnuexit_Click() '退出
 End
End Sub

Private Sub mnufind_Click()  '查找
FindText 1
mnuNext.Enabled = True
End Sub

Private Sub mnufont_Click()    '字体
On Error GoTo A:

   cmndlg1.Flags = cdlCFBoth Or cdlCFEffects
   cmndlg1.ShowFont
    If cmndlg1.FontName > "" Then
       Text1.FontName = cmndlg1.FontName
    End If
    Text1.FontSize = cmndlg1.FontSize
    Text1.FontBold = cmndlg1.FontBold
    Text1.FontItalic = cmndlg1.FontItalic
    Text1.FontStrikethru = cmndlg1.FontStrikethru
    Text1.FontUnderline = cmndlg1.FontUnderline
    Text1.FontBold = cmndlg1.FontBold
    Text1.ForeColor = cmndlg1.Color
A:
  If Err.Number < 0 Then
Exit Sub
End If
End Sub

Private Sub mnufontcolor_Click()   '字体颜色
cmndlg1.ShowColor
Text1.ForeColor = cmndlg1.Color
End Sub

Private Sub mnuleft_Click()   '左对齐
   Text1.Alignment = 0
    mnuleft.Checked = True
    mnuright(1).Checked = False
    mnuright(2).Checked = False
End Sub
Private Sub mnunew_Click()   '新建
   Text1.Text = ""
End Sub
Private Sub FindTex(ByVal start_at As Integer)

targey = targey
pos = InStr(start_at, Text1.Text, targey)
If pos > 0 Then '找到了匹配字符串
TargetPosition = pos
Text1.SelStart = TargetPosition - 1
'选中找到的字符串
Text1.SelLength = Len(targey)
Text1.SetFocus
Else '没有找到匹配的字符串
MsgBox "没找到匹配的字符串", 48, "提示"
Text1.SetFocus
End If
End Sub
Private Sub mnuNext_Click()  '查找下一个
FindTex TargetPosition + 1


End Sub

Private Sub mnuopen_Click()  '打开
Dim inputdata As String
 On Error GoTo nofile
   cmndlg1.Filter = "文本文件|*.txt"
    cmndlg1.CancelError = True
     cmndlg1.ShowOpen
      Text1.Text = ""
    If cmndlg1.FileName <> "" Then
      Open cmndlg1.FileName For Input As #1
   Do While Not EOF(1)
      Line Input #1, inputdata
      Text1.Text = Text1.Text & inputdata & vbCr
   Loop
 Close #1
 End If
   Exit Sub
nofile:
      If Err.Number = 32755 Then Exit Sub

End Sub
Private Sub FindText(ByVal start_at As Integer)
'获取用户输入的要查找的字符串
targey = InputBox("请输入要查找的内容", "查找")
pos = InStr(start_at, Text1.Text, targey)
If pos > 0 Then '找到了匹配字符串
TargetPosition = pos
Form1.Text1.SelStart = TargetPosition - 1
'选中找到的字符串
Form1.Text1.SelLength = Len(targey)
Form1.Text1.SetFocus
Else '没有找到匹配的字符串
MsgBox "没找到匹配的字符串", 48, "提示"
Form1.Text1.SetFocus
End If
End Sub
Private Sub mnupaste_Click()   '粘贴   用GetText1 方法,将剪切板中的内容粘贴到光标所在位置
   Text1.SelText = Clipboard.GetText()
End Sub

Private Sub mnuprint_Click() '打印
On Error Resume Next
   cmndlg1.ShowPrinter
    Printer.Copies = cmndlg1.Copies
     Printer.Print Text1.Text
End Sub

Private Sub mnuright_Click(Index As Integer)  '右对齐\居中菜单代码
Select Case Index
Case 1
Text1.Alignment = 1
mnuleft.Checked = False
mnuright(1).Checked = True
mnuright(2).Checked = False
Case 2
Text1.Alignment = 2
mnuleft.Checked = False
mnuright(1).Checked = False
mnuright(2).Checked = True
End Select
End Sub

Private Sub mnusave_Click()  '保存
  On Error Resume Next
  cmndlg1.DialogTitle = "保存文件"
    cmndlg1.Filter = "文本文件|*.txt"
    cmndlg1.CancelError = True
    cmndlg1.ShowSave
      Open cmndlg1.FileName For Output As #1
       Print #1, Text1.Text
       Close #1
End Sub

Private Sub mnuselectall_Click()    '全选
  Text1.SelStart = 0
  Text1.SelLength = Len(Text1.Text)
End Sub


Private Sub Text1_Change()
If Text1.Text = "" Then
mnufind.Enabled = False
mnuNext.Enabled = False
Else
mnufind.Enabled = True
mnuselectall.Enabled = True
End If
End Sub

Private Sub Toolbar1_ButtonClick(ByVal Button As MSComctlLib.Button)
Select Case Button
Case "新建"
Call mnunew_Click
Case "打开"
Call mnuopen_Click
Case "剪切"
Call mnucut_Click
Case "复制"
Call mnucopy_Click
Case "粘贴"
Call mnupaste_Click
Case "保存"
Call mnusave_Click
Case "查找"
Call mnufind_Click
End Select
End Sub

Private Sub tre_Click()
Shell ("notepad 帮助文件.txt")
End Sub