📄 pygl.frm
字号:
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form formMain
BorderStyle = 3 'Fixed Dialog
Caption = "颖志---中小学评语管理系统"
ClientHeight = 5565
ClientLeft = 150
ClientTop = 435
ClientWidth = 8415
Icon = "pygl.frx":0000
LinkTopic = "Form1"
MaxButton = 0 'False
MinButton = 0 'False
MousePointer = 99 'Custom
ScaleHeight = 5565
ScaleWidth = 8415
ShowInTaskbar = 0 'False
StartUpPosition = 3 '窗口缺省
Begin VB.CommandButton CmdOpenOrNew
Caption = "打开..."
Height = 345
Left = 6735
TabIndex = 11
Top = 1380
Width = 870
End
Begin VB.CommandButton cmdset
Caption = "设置评语输入(&R)"
Height = 405
Left = 5955
TabIndex = 10
Top = 3810
Width = 1665
End
Begin VB.FileListBox filelist
BackColor = &H80000013&
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 2970
Left = 3570
TabIndex = 9
Top = 1950
Width = 2205
End
Begin VB.CommandButton cmdend
Caption = "结束(&X)"
Height = 405
Left = 5955
TabIndex = 7
Top = 4380
Width = 1665
End
Begin VB.CommandButton cmdOutPutDoc
Caption = "输出到&Word"
Height = 405
Left = 5940
TabIndex = 6
Top = 3210
Width = 1665
End
Begin VB.CommandButton CmdOutPutTxt
Caption = "输出到记事本(&T)"
Height = 405
Left = 5940
TabIndex = 5
Top = 2640
Width = 1665
End
Begin VB.CommandButton CmdInput
Caption = "评语输入(&I)"
Height = 405
Left = 5940
TabIndex = 4
Top = 2055
Width = 1665
End
Begin VB.TextBox TxtFileName
BorderStyle = 0 'None
BeginProperty Font
Name = "宋体"
Size = 10.5
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 330
Left = 1920
TabIndex = 2
Top = 1395
Width = 4800
End
Begin VB.Frame Frame1
Height = 3015
Left = 720
TabIndex = 0
Top = 1875
Width = 2760
Begin VB.DirListBox dirlist
Height = 2400
Left = 90
TabIndex = 8
Top = 540
Width = 2565
End
Begin VB.DriveListBox drvlist
Height = 300
Left = 60
TabIndex = 1
Top = 180
Width = 2610
End
End
Begin MSComDlg.CommonDialog CmmDialog
Left = 7260
Top = 120
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Label Label2
AutoSize = -1 'True
Caption = "作者：全思成 Email:qscandwh@163.com"
Height = 180
Left = 2280
TabIndex = 12
Top = 480
Width = 3330
End
Begin VB.Shape Shape2
Height = 2955
Left = 5820
Top = 1950
Width = 1875
End
Begin VB.Shape Shape1
Height = 3705
Left = 585
Top = 1290
Width = 7215
End
Begin VB.Label Label1
AutoSize = -1 'True
Caption = "导出文件:"
BeginProperty Font
Name = "宋体"
Size = 12
Charset = 134
Weight = 400
Underline = 0 'False
Italic = 0 'False
Strikethrough = 0 'False
EndProperty
Height = 240
Left = 810
TabIndex = 3
Top = 1455
Width = 1080
End
End
Attribute VB_Name = "formMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim MyWord As Object
Dim NewDoc As Object
Private Declare Function ShellExecuteForExplore Lib "shell32.dll" Alias "ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, lpParameters As Any, lpDirectory As Any, ByVal nShowCmd As Long) As Long
Private Sub cmdend_Click()
Unload Me
End
End Sub
Private Sub CmdInput_Click()
FormInput.Show
End Sub
Private Sub CmdOpenOrNew_Click()
If Trim(TxtFileName.Text) <> "" Then ShellExecuteForExplore formMain.hwnd, "open", TxtFileName.Text, 0, 0, 1: Exit Sub
Dim FilePath As String
CmmDialog.CancelError = True
On Error GoTo ErrLine
If Trim(TxtFileName.Text) = "" Then
CmmDialog.DialogTitle = "新建---评语文件"
CmmDialog.DefaultExt = ".txt"
CmmDialog.FLAGS = cdlOFNHideReadOnly
CmmDialog.Filter = "所有文件 (*.*)|*.*|文本文件" & _
"(*.txt)|*.txt|Word 文件 (*.Doc)|*.Doc"
' 指定缺省的过滤器
CmmDialog.ShowOpen
ShellExecuteForExplore Me.hwnd, "open", CmmDialog.FileName, 0, 0, 1
End If
Exit Sub
ErrLine: ' 用户按了“取消”按钮
End Sub
Private Sub cmdOutPutDoc_Click()
SaveTo_Word
End Sub
Private Sub CmdOutPutTxt_Click()
SaveTo_Txt
'OpenRs
End Sub
Private Sub cmdset_Click()
formcase.Show
End Sub
Private Sub dirlist_Change()
filelist.Path = dirlist.Path
ChDir (dirlist.Path)
End Sub
Private Sub drvlist_Change()
On Error GoTo line
dirlist.Path = drvlist.Drive
ChDrive (drvlist.Drive)
Exit Sub
line:
MsgBox Err.Description, vbCritical, "设备错误!"
drvlist.Drive = dirlist.Path
End Sub
Private Sub filelist_Click()
TxtFileName.Text = filelist.FileName
TxtFileName.Text = filelist.Path + "\" + filelist.FileName
End Sub
Private Sub Form_Activate()
TxtFileName.SetFocus
End Sub
Private Sub Form_Load()
'StayOnTop formMain
CenterForm formMain
IsClick = True
CnStr = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\StudentRemark.mdb;Persist Security Info=False"
If AdoCnn.State = 0 Then AdoCnn.Open CnStr
OpenRs
End Sub
Sub SaveTo_Txt()
If Trim(TxtFileName.Text) = "" Then MsgBox "请输入文件名", vbExclamation, "错误": Exit Sub
Dim Extend As String
Extend = Right(TxtFileName.Text, 4)
If Mid(Extend, 1, 1) = "." Then
TxtFileName.Text = Mid(TxtFileName.Text, 1, Len(TxtFileName.Text) - 4) + ".txt"
Else
TxtFileName.Text = TxtFileName.Text + ".txt"
End If
Dim Num_fields As Integer
Num_fields = RS.Fields.Count
Dim Field_Value As String
OpenRs '打开记录集
Dim Fnum As Integer
Fnum = FreeFile
Open TxtFileName.Text For Output As Fnum
Do While Not RS.EOF
Field_Value = Trim(RS.Fields("学号").Value)
Print #Fnum, "学号："; Field_Value & Space$(6); _
"姓名:" & Trim(RS.Fields("姓名").Value)
Print #Fnum, Space$(4); Trim(RS.Fields("评语").Value)
Print #Fnum, '将空白行写入文件。
RS.MoveNext
Loop
Close Fnum
RS.Close: Set RS = Nothing
MsgBox "成功导入记事本", vbOKOnly, "数据导入"
End Sub
Sub SaveTo_Word()
If Trim(TxtFileName.Text) = "" Then MsgBox "请输入文件名", vbExclamation, "文件导入": Exit Sub
Dim Extend As String
Extend = Right(TxtFileName.Text, 4)
If Mid(Extend, 1, 1) = "." Then
TxtFileName.Text = Mid(TxtFileName.Text, 1, Len(TxtFileName.Text) - 4) + ".doc"
Else
TxtFileName.Text = TxtFileName.Text + ".doc"
End If
Me.MousePointer = 11
Me.Enabled = False
Dim Num_fields As Integer
Num_fields = RS.Fields.Count
Dim Field_Value As String
OpenRs '打开记录集
Dim Fnum As Integer
Fnum = FreeFile
Open "c:\temp.txt" For Output As Fnum
Do While Not RS.EOF
Field_Value = Trim(RS.Fields("学号").Value)
Print #Fnum, "学号："; Field_Value & Space$(6); _
"姓名:" & Trim(RS.Fields("姓名").Value)
Print #Fnum, Space$(4); Trim(RS.Fields("评语").Value)
Print #Fnum, '将空白行写入文件。
RS.MoveNext
Loop
Close Fnum
RS.Close: Set RS = Nothing
'导入记事本
Dim Fso As New FileSystemObject
Dim F As File, TS As TextStream, S As String
Set F = Fso.GetFile("c:\temp.txt")
Set TS = F.OpenAsTextStream(ForReading)
S = TS.ReadAll
'写入Word
Set MyWord = CreateObject("Word.Application")
MyWord.Visible = False
MyWord.Caption = "考试"
Set NewDoc = Nothing
Set NewDoc = MyWord.Documents.Add
NewDoc.Paragraphs(1).Range.Text = S
NewDoc.SaveAs TxtFileName.Text
TS.Close
Fso.DeleteFile "c:\temp.txt", True
MyWord.Quit
Me.MousePointer = 1
Me.Enabled = True
MsgBox "成功导入Word", vbExclamation, "导入提示!"
End Sub
Sub OpenRs()
'Dim big_string As String
If RS.State = 1 Then RS.Close
RS.Open "select * from [学生信息] order by 学号 asc ", AdoCnn
'big_string = RS.GetString(adClipString)
'Open "c:\my.txt" For Output As #1
'Write #1, big_string
'Close #1
End Sub
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -