'窗体代码
东洲网站制作公司哪家好，找创新互联！从网页设计、网站建设、微信开发、APP开发、响应式网站设计等网站项目制作，到程序开发，运营维护。创新互联于2013年开始到现在10年的时间，我们拥有了丰富的建站经验和运维经验，来保证我们的工作的顺利进行。专注于网站建设就选创新互联。
Option Explicit
Dim filename As String
Dim FileType As String
Dim FiType As String
Dim sFind As String
Dim result As String
Dim bWrap As Boolean
Dim ask As Boolean
Dim msgtext As String
Dim Flag As String
Private Sub Form_Load()
ask = False
RichText.Text = ""
filename = "无标题-记事本"
Form1.Caption = "无标题-记事本"
RichText.Height = Form1.ScaleHeight
RichText.Width = Form1.ScaleWidth
StatusBar1.Visible = False
StatusBar1.Panels(1).Text = Time
mnucopy.Enabled = False
mnucut.Enabled = False
mnufound.Enabled = False
mnufoundnext.Enabled = False
mnudel.Enabled = False
mnucancel.Enabled = False
mnuwordwrap.Checked = True
mnugoto.Enabled = False
If Clipboard.GetText "" Then
mnuplaster.Enabled = True
Else
mnuplaster.Enabled = False
End If
App.HelpFile = App.Path "\notepad.chm"
End Sub
Private Sub Form_Resize()
RichText.Height = Form1.ScaleHeight
RichText.Width = Form1.ScaleWidth
End Sub
Private Sub Form_Unload(Cancel As Integer)
msgtext = "文件" filename "的文字已经改变。" Chr(10) Chr(13) "想保存文件吗？"
If ask = True Then
Flag = MsgBox(msgtext, 35, "记事本") ' 35=32+3
If Flag = vbYes Then mnusave_Click '选择了确定则保存之
If Flag = vbCancel Then Cancel = True
If Flag = vbNo Then Unload Me
End If
End Sub
Private Sub mnuabout_Click()
MsgBox "记事本", vbOKOnly, "关于"
End Sub
Private Sub mnuall_Click()
RichText.SelStart = 0
RichText.SelLength = Len(RichText.Text)
End Sub
Private Sub mnucancel_Click()
MsgBox "请点击鼠标右键撤销！", vbOKOnly, "提示"
End Sub
Private Sub mnucopy_Click()
Clipboard.Clear
Clipboard.SetText RichText.SelText
End Sub
Private Sub mnucut_Click()
Clipboard.Clear
Clipboard.SetText RichText.SelText
RichText.SelText = ""
End Sub
Private Sub mnudel_Click()
RichText.SelText = ""
End Sub
Private Sub mnuedit_Click()
If RichText.SelText "" Then
mnuopen.Enabled = True
mnucut.Enabled = True
mnudel.Enabled = True
mnucopy.Enabled = True
End If
If Len(RichText.Text) 0 Then
mnufound.Enabled = True
mnufoundnext.Enabled = True
End If
If ask = True Then mnucancel.Enabled = True
End Sub
Private Sub mnuexit_Click()
Unload Me
End Sub
Private Sub mnufont_Click()
On Error Resume Next
CommonDialog1.flags = H3 Or H1 Or H2 Or H100
CommonDialog1.Action = 4
RichText.Font.Name = CommonDialog1.FontName
RichText.Font.Size = CommonDialog1.FontSize
RichText.Font.Bold = CommonDialog1.FontBold
RichText.Font.Italic = CommonDialog1.FontItalic
RichText.Font.Underline = CommonDialog1.FontUnderline
RichText.SelColor = CommonDialog1.Color
End Sub
Private Sub mnufound_Click()
sFind = InputBox("请输入要查找的字、词：", "查找内容", sFind)
RichText.Find sFind
End Sub
Private Sub mnufoundnext_Click()
RichText.SelStart = RichText.SelStart + RichText.SelLength + 1
RichText.Find sFind, , Len(RichText)
End Sub
Private Sub mnuhelptopic_Click()
SendKeys "{F1}"
End Sub
Private Sub mnunewfile_Click()
On Error Resume Next
Dim n As Integer
msgtext = "文件" filename "的文字已经改变。" Chr(10) Chr(13) "想保存文件吗？"
If Len(RichText.Text) 0 Then
If filename = "无标题-记事本" Then
Flag = MsgBox(msgtext, 35, "记事本") '给予提示
If Flag = vbYes Then
mnusaveas_Click
RichText.Text = ""
Form1.Caption = "无标题-记事本"
filename = "无标题-记事本"
End If
If Flag = vbCancel Then Exit Sub
If Flag = vbNo Then
RichText.Text = ""
Form1.Caption = "无标题-记事本"
filename = "无标题-记事本"
End If
End If
End If
End Sub
Private Sub mnuopen_Click()
msgtext = "文件" filename "的文字已经改变。" Chr(10) Chr(13) "想保存文件吗？"
On Error Resume Next
If ask = True Then
Flag = MsgBox(msgtext, 35, "记事本") '给予提示
If Flag = vbYes Then mnusave_Click '选择了确定则保存之
If Flag = vbCancel Then Exit Sub
If Flag = vbNo Then GoTo L1
End If
ask = False
L1: CommonDialog1.Filter = "文本文档(*.txt)|*.txt|RTF文档(*.rtf)|*.rtf|所有文件(*.*)|*.*"
CommonDialog1.ShowOpen
RichText.Text = "" '清空文本框
filename = CommonDialog1.filename
RichText.LoadFile filename
result = GetFileTitle(filename)
Me.Caption = "" result "-记事本"
End Sub
Private Sub mnupagesetup_Click()
psdlg.lStructSize = Len(psdlg)
psdlg.hwndOwner = hwnd
PageSetupDlg psdlg
End Sub
Private Sub mnuplaster_Click()
RichText.SelText = Clipboard.GetText(1)
End Sub
Private Sub mnuprint_Click()
Dim f As Integer, t As Integer
Dim i As Integer
CommonDialog1.CancelError = True
CommonDialog1.Max = 1000
CommonDialog1.Min = 1
On Error Resume Next
CommonDialog1.ShowPrinter
For f = CommonDialog1.FromPage To t = CommonDialog1.ToPage
Do While i CommonDialog1.Copies + 1
Printer.Print RichText.Text
i = i + 1
Loop
Next
Printer.EndDoc
Cancel:
If Err.Number = 32755 Then
Exit Sub
End If
End Sub
Private Sub mnusave_Click()
CommonDialog1.Filter = "文本文档(*.txt)|所有文件(*.*)|*.*"
On Error Resume Next
filename = CommonDialog1.filename '保存文件
If filename "" Then
RichText.SaveFile filename, rtfText
Else
mnusaveas_Click
End If
ask = False
End Sub
Private Sub mnusaveas_Click()
CommonDialog1.Filter = "文本文档(*.txt)|所有文件(*.*)|*.*"
On Error Resume Next
CommonDialog1.ShowSave
filename = CommonDialog1.filename
RichText.SaveFile filename, rtfText
result = GetFileTitle(filename)
Me.Caption = "" result "-记事本"
ask = False
End Sub
Private Sub mnustatusbar_Click()
If mnustatusbar.Checked Then
StatusBar1.Visible = False
mnustatusbar.Checked = False
Else
StatusBar1.Visible = True
mnustatusbar.Checked = True
End If
End Sub
Private Sub mnutimedate_Click()
RichText.SelText = Format(Now, "h:mm ddddd")
End Sub
Private Sub mnuwordwrap_Click()
WrapTextLine RichText, bWrap
bWrap = Not bWrap
If mnuwordwrap.Checked = False Then
HScroll1.Enabled = True
mnuwordwrap.Checked = True
Else
HScroll1.Enabled = False
mnuwordwrap.Checked = False
End If
End Sub
Private Sub RichText_Change()
ask = True
End Sub
Private Sub Timer1_Timer()
If StatusBar1.Panels(1).Text CStr(Time) Then
StatusBar1.Panels(1).Text = Time
End If
End Sub
'模块代码
Option Explicit
Const WM_USER = H400
Const EM_SETTARGETDEVICE = (WM_USER + 72)
Type POINTAPI
x As Long
y As Long
End Type
Type RECT
left As Long
right As Long
top As Long
bottom As Long
End Type
Public Type PageSetupDlg
lStructSize As Long
hwndOwner As Long
hDevMode As Long
hDevNames As Long
flags As Long
ptPaperSize As POINTAPI
rtMinMargin As RECT
rtMargin As RECT
hInstance As Long
lCustData As Long
lpfnPageSetupHook As Long
lpfnPagePaintHook As Long
lpPageSetupTemplateName As String
hPageSetupTemplate As Long
End Type
Public psdlg As PageSetupDlg
Declare Function PageSetupDlg Lib "comdlg32.dll" Alias "PageSetupDlgA" (pPagesetupdlg As PageSetupDlg) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
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
Dim bWrap As Boolean '// 换行标记'// 自定义一个换行的过程
Public Sub WrapTextLine(ByRef RichText As RichTextBox, ByVal bWrapSwitch As Boolean)
On Error Resume Next
If bWrapSwitch Then '// 设置 RichTextBox 自动换行
SendMessage RichText.hwnd, EM_SETTARGETDEVICE, GetDC(RichText.hwnd), RichText.Width / 15
RichText.RightMargin = IIf(RichText.RightMargin = 0, 1, 0)
Else
'// 设置 RichTextBox 不自动换行
SendMessage RichText.hwnd, EM_SETTARGETDEVICE, 0, 1
End If
End Sub
Function GetFileTitle(OldStr As String) As String
On Error Resume Next
Dim n As Integer, m As Integer '声明字符串变量
Dim i As String, r As String
Dim p As Integer
i = "\" '要查找的指定字符
For n = 1 To Len(OldStr) '用Len函数计算已知字符串的字节数
m = InStrRev(OldStr, i, -1) '"\"所在的位置(其中的-1是默认的)
Next n '找下去！
'截取最后一个"\"后面的字符串
r = right(OldStr, Len(OldStr) - m) '获取Title
p = InStrRev(r, ".", -1) '"."所在位置
GetFileTitle = left(r, p - 1) '去掉后缀
End Function
Dim sFileName As String
Dim Search
Private Sub dateTimeMenu_Click()
Text1.Text = Now
End Sub
Private Sub deleteMenu_Click()
Text1.Text = Left(Text1.Text, Text1.SelStart) + Mid(Text1.Text, Text1.SelStart + Text1.SelLength + 1)
End Sub
Private Sub findMenu_Click()
Search = InputBox("请输入要查找的字词：")
Dim Where1 '获取需要查找的字符串变量
Text1.SetFocus '文本框获得焦点，以显示所找到的内容Search = InputBox("请输入要查找的字词：")
Where1 = InStr(Text1.Text, Search) '在文本中查找字符串
If Where1 Then
'若找到则设置选定的起始位置并使找到的字符串高亮
Text1.SelStart = Where1 - 1
Text1.SelLength = Len(Search)
' Me.Caption = Where1 '测试用
'否则给出提示
Else: MsgBox "未找到所要查找的字符串。", vbInformation, "提示"
End If
End Sub
Private Sub findNextMenu_Click()
Dim Where2
Dim StartMe As Integer '查找的起始位置变量
Text1.SetFocus '文本框获得焦点
StartMe = Text1.SelLength + Text1.SelStart + 1 '给变量赋值
Where2 = InStr(StartMe, Text1.Text, Search) '令其从上次找到的地方找起
If Where2 Then
Text1.SelStart = Where2 - 1
Text1.SelLength = Len(Search)
Else: MsgBox "未找到所要查找的字符串.", vbInformation, "提示"
End If
End Sub
Private Sub aboutMenu_Click()
MsgBox Space(2) "文本编辑器版本号1.0" Chr(13) "由西南财经大学天府学院" Chr(13) Space(5) "肖忠 开发" Chr(13) Space(2) "copyright:天府学院"
End Sub
Private Sub allMenu_Click()
Text1.SelStart = 0
Text1.SelLength = Len(Text1.Text)
End Sub
Private Sub backcolorMenu_Click() '设置背景色代码
Form1.CommonDialog1.Action = 3
Text1.BackColor = Form1.CommonDialog1.Color
End Sub
Private Sub colorMenu_Click() '改变文字颜色代码
Form1.CommonDialog1.Action = 3
Text1.ForeColor = Form1.CommonDialog1.Color
End Sub
Private Sub cutMenu_Click()
Clipboard.SetText Text1.SelText
Text1.Text = Left(Text1.Text, Text1.SelStart) + Mid(Text1.Text, Text1.SelStart + Text1.SelLength + 1)
End Sub
Private Sub exitMenu_Click()
End
End Sub
Private Sub fontMenu_Click() '字体菜单代码
Form1.CommonDialog1.Flags = 3 Or 256
Form1.CommonDialog1.Action = 4
If Len(Form1.CommonDialog1.FontName) = 0 Then
Form1.Text1.FontName = "宋体"
Else
Form1.Text1.FontName = Form1.CommonDialog1.FontName
End If
Form1.Text1.FontSize = Form1.CommonDialog1.FontSize
If Form1.CommonDialog1.FontBold = True Then
Form1.Text1.FontBold = True
Else
Form1.Text1.FontBold = False
End If
If Form1.CommonDialog1.FontItalic = True Then
Form1.Text1.FontItalic = True
Else
Form1.Text1.FontItalic = False
End If
Text1.ForeColor = Form1.CommonDialog1.Color
End Sub
Private Sub Form_Load()
Form1.Text1.Width = Form1.Width - 130
Form1.Text1.Height = Form1.Height
End Sub
Private Sub Form_Resize()
Form1.Text1.Width = Form1.Width - 130
Form1.Text1.Height = Form1.Height
End Sub
Private Sub help1Menu_Click()
Form1.CommonDialog1.HelpCommand = cdlHelpForceFile
Form1.CommonDialog1.HelpFile = "c:\windows\system32\winhelp.hlp"
CommonDialog1.ShowHelp
End Sub
Private Sub newMenu_Click()
If Len(Trim(Text1.Text)) = 0 Then
Form1.Caption = "我的记事本" "--" "未命名"
sFileName = "未命名"
Text1.FontSize = 15
Text1.FontName = "宋体"
Text1.Text = ""
Else
Call saveAsMenu_Click
Form1.Caption = "我的记事本" "--" "未命名"
sFileName = "未命名"
Text1.FontSize = 15
Text1.FontName = "宋体"
Text1.Text = ""
End If
End Sub
Private Sub openMenu_Click() '打开文件代码
If Len(Trim(Text1.Text)) = 0 Then
Form1.Caption = "我的记事本"
Form1.CommonDialog1.Filter = "文本文件|*.txt"
Form1.CommonDialog1.Flags = 4096
Form1.CommonDialog1.Action = 1
If Len(Form1.CommonDialog1.FileName) 0 Then
sFileName = Form1.CommonDialog1.FileName
Form1.Caption = Form1.Caption "--" Form1.CommonDialog1.FileTitle
Open sFileName For Input As #1
Text1.FontSize = 15
Text1.FontName = "宋体"
Do While Not EOF(1)
Line Input #1, Text$
All$ = All$ + Text$ + Chr(13) + Chr(10)
Loop
Text1.Text = All
Close #1
End If
Else
Call saveAsMenu_Click
Form1.Caption = "我的记事本"
Form1.CommonDialog1.Filter = "文本文件|*.txt"
Form1.CommonDialog1.Flags = 4096
Form1.CommonDialog1.Action = 1
If Len(Form1.CommonDialog1.FileName) 0 Then
sFileName = Form1.CommonDialog1.FileName
Form1.Caption = Form1.Caption "--" Form1.CommonDialog1.FileTitle
Open sFileName For Input As #1
Text1.FontSize = 15
Text1.FontName = "宋体"
Do While Not EOF(1)
Line Input #1, Text$
All$ = All$ + Text$ + Chr(13) + Chr(10)
Loop
Text1.Text = All
Close #1
End If
End If
End Sub
Private Sub pasteMenu_Click() '粘贴菜单代码
Text1.Text = Left(Text1.Text, Text1.SelStart) + Clipboard.GetText() + Mid(Text1.Text, Text1.SelStart + Text1.SelLength + 1)
End Sub
Private Sub printMenu_Click()
Form1.CommonDialog1.ShowPrinter
For i = 1 To CommonDialog1.Copies
Printer.Print Text1.Text
Printer.Print Text1.Text
Next
Printer.EndDoc
End Sub
Private Sub saveAsMenu_Click() '另存为菜单代码
If Len(Trim(Text1.Text)) 0 Then
Form1.CommonDialog1.DialogTitle = "保存文件"
Form1.CommonDialog1.InitDir = "D:\"
Form1.CommonDialog1.Filter = "文本文件|*.txt"
Form1.CommonDialog1.Flags = 2
Form1.CommonDialog1.ShowSave
If Len(Form1.CommonDialog1.FileName) 0 Then
sFileName = Form1.CommonDialog1.FileName
Open sFileName For Output As #1
whole$ = Text1.Text
Print #1, whole
Close #1
End If
End If
End Sub
Private Sub saveMenu_Click()
If Len(Trim(Text1.Text)) 0 Then
Form1.CommonDialog1.DialogTitle = "保存文件"
Form1.CommonDialog1.InitDir = "D:\"
Form1.CommonDialog1.FileName = "新建文本"
Form1.CommonDialog1.Filter = "文本文件|*.txt"
Form1.CommonDialog1.Flags = 2
Form1.CommonDialog1.ShowSave
If Len(Form1.CommonDialog1.FileName) 0 Then
sFileName = Form1.CommonDialog1.FileName
Open sFileName For Output As #1
whole$ = Text1.Text
Print #1, whole
Close #1
End If
End If
End Sub
Private Sub statusMenu_Click()
End Sub
vb编写的简单记事本代码
Dim b As String
Dim a As String
Dim m As String
Dim x As String
Private 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
Const HWND_TOPMOST = -1
Const SWP_SHOWWINDOW = H40
Private Sub baocun_Click()
Dim abc As String
If Len(Trim(m)) = 0 Then
m = "f:"
End If
abc = m "\" Text2.Text ".txt"
Open abc For Output As #1
Write #1, Text1.Text
Close #1
Label2.Caption = "保存的路径为：" m "\" Text2.Text ".txt"
a = MsgBox("保存成功！" Chr(13) "是否退出程序", 4 + 64 + 0, "提示")
If a = vbYes Then
End
End If
End Sub
Private Sub Command1_Click()
Dir1.Visible = False
Drive1.Visible = False
m = Dir1.Path
Command1.Visible = False
b = MsgBox("你选的文件夹是：" m, vbYesNo + vbDefaultButton1 + 48, "提示")
If b = vbNo Then
Dir1.Visible = True
Drive1.Visible = True
Command1.Visible = True
Else
Dir1.Visible = False
Drive1.Visible = False
Command1.Visible = False
End If
End Sub
Private Sub Command2_Click()
MsgBox (App.Path + "1.ico")
End Sub
Private Sub dakai_Click()
CommonDialog1.Filter = "文本文件(*.txt)|*.txt"
CommonDialog1.ShowOpen
Open CommonDialog1.FileName For Input As #1
Dim abc As String
linefromfile = StrConv(InputB(LOF(1), 1), vbUnicode)
Text1.Text = linefromfile
Close #1
End Sub
Private Sub Drive1_Change()
Dir1.Path = Drive1.Drive
End Sub
Private Sub Form_Load()
Drive1.Drive = "f:\"
Dir1.Visible = False
Drive1.Visible = False
Command1.Visible = False
Dim fullpath As String
If Right(App.Path, 1) = "\" Then
fullpath = App.Path + "1.ico"
Else
fullpath = App.Path + "\" + "1.ico"
Form1.Icon = LoadPicture(fullpath)
End If
End Sub
Private Sub lingcunwei_Click()
Dim abc As String
CommonDialog1.ShowSave
If Len(Trim(CommonDialog1.FileName)) 0 Then
x = CommonDialog1.FileName
Else
x = "f:\1.txt"
End If
Open x For Append As #1
Write #1, Text1.Text
Close #1
End Sub
Private Sub s_Click()
Text1.FontSize = 5
End Sub
Private Sub sanhao_Click()
Text1.FontSize = 12
End Sub
Private Sub st_Click()
CommonDialog1.ShowFont
End Sub
Private Sub shybcdwjj_Click()
Dir1.Visible = True
Drive1.Visible = True
Command1.Visible = True
End Sub
Private Sub Text2_GotFocus()
Dir1.Visible = False
Drive1.Visible = False
Command1.Visible = False
End Sub
Private Sub tuichu_Click()
End
End Sub
Private Sub wh_Click()
Text1.FontSize = 10
End Sub
Private Sub whs_Click()
Text1.FontSize = 10.5
End Sub
Private Sub xinjian_Click()
Text1.Text = ""
Text2.Text = ""
End Sub
Private Sub yh_Click()
Text1.FontSize = 24
End Sub
Private Sub zstj_Click()
MsgBox "所有字数为" Len(Text1.Text), , " 字数"
End Sub
Private Sub ztys_Click()
CommonDialog1.ShowColor
Text1.ForeColor = CommonDialog1.Color
End Sub
Private Sub zzqm_Click()
Dim retValue As Long
'将窗体设置为处于所有窗口的顶层，注意在 VB 中运行时，可能不行，但编译成EXE后就可以了
retValue = SetWindowPos(Me.hwnd, HWND_TOPMOST, Me.CurrentX, Me.CurrentY, 380, 615, SWP_SHOWWINDOW)
End Sub
