介绍如何利用EXCEL对象操作.XLS文件,而不使用DAO等。下面是一个示例代码,昨天写的,是高中学分评定的一个辅助工具,可以把班主任做好的表里面的学号和姓名都弄过来并自动添加对应学分:)以上这些都是固定的啦,用起来省去不少工夫,当然了,这里主要是介绍VB中用EXCEL操作XLS文件,不讨论在EXCEL里直接用VBA实现的问题~~~;还有一个提供“模板”的功能:把学生的分数用一个模拟函数同时输入进去,这个功能大家不要用来作弊哦~~~自己学生的成绩还是要自己一个一个填的才对的起学生麻!而且那个模拟函数,说实在的,就是简单写了几句,模拟的情况并不是很好啦~~~
下面看代码:(工程中除必须引用对象外没有对任何对象进行引用,在FORM1里面名字为XlsOpenCD的是一个commandDialog控件,如果测试时提示找不到,请将其删除并填加commandDialog控件,将其命名为XlsOpenCD)
注意:代码由一个窗体(FORM1)和三个模块及一个资源文件组成;你复制下来后直接测试会提示错误的,把FORM_LOAD事件里面对模块3中SetLogo函数的调用注释掉就可以啦。代码写的仓促,没有整理,但是要介绍的EXCEL对象基本介绍清楚了。(简述一下思路:建立一个表格文件并保持打开状态,打开要填加的表格,获取相应数据后加入建立的表格中,关闭打开的表格,关闭建立的表格。)
'以下复制后保存为FORM1.FRM
VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.ocx"
Begin VB.Form Form1
Caption = "高中学分评定 任课教师报表辅助工具 V1.1.0"
ClientHeight = 5325
ClientLeft = 60
ClientTop = 345
ClientWidth = 12240
LinkTopic = "Form1"
MaxButton = 0 'False
ScaleHeight = 5325
ScaleWidth = 12240
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame6
Height = 855
Left = 10080
TabIndex = 27
Top = 4440
Width = 2055
Begin VB.PictureBox LogoPic
Appearance = 0 'Flat
BorderStyle = 0 'None
ForeColor = &H80000008&
Height = 710
Left = 30
MouseIcon = "Form1.frx":0000
MousePointer = 99 'Custom
ScaleHeight = 705
ScaleWidth = 1980
TabIndex = 28
Top = 120
Width = 1980
End
End
Begin VB.Frame Frame5
Caption = "操作结束:"
Height = 735
Left = 60
TabIndex = 19
Top = 3600
Width = 12135
Begin VB.CheckBox Check5
Caption = "单击“表格编辑结束”打开生成的表格所在文件夹"
Height = 255
Left = 4800
TabIndex = 22
Top = 300
Value = 1 'Checked
Width = 4455
End
Begin VB.CheckBox Check4
Caption = "单击“表格编辑结束”打开生成的表格"
Height = 255
Left = 480
TabIndex = 21
Top = 300
Value = 1 'Checked
Width = 3495
End
Begin VB.CommandButton Command3
Caption = "表格编辑结束"
Height = 375
Left = 10200
TabIndex = 20
Top = 240
Width = 1695
End
End
Begin MSComDlg.CommonDialog XlsOpenCD
Left = 8880
Top = 3720
_ExtentX = 847
_ExtentY = 847
_Version = 393216
End
Begin VB.Frame Frame4
Caption = "操作信息:"
Height = 855
Left = 60
TabIndex = 10
Top = 4440
Width = 9975
Begin VB.Label Label6
Caption = "准备完毕"
Height = 495
Left = 480
TabIndex = 11
Top = 240
Width = 9255
End
End
Begin VB.Frame Frame3
Caption = "项目添加操作:"
Height = 2535
Left = 10020
TabIndex = 8
Top = 960
Width = 2175
Begin VB.CheckBox Check1
Caption = "成绩真实情况模拟"
Height = 495
Left = 120
TabIndex = 26
Top = 600
Value = 1 'Checked
Width = 1815
End
Begin VB.CheckBox Check2
Caption = "总分按 150 计"
Height = 495
Left = 120
TabIndex = 25
Top = 240
Width = 1695
End
Begin VB.CheckBox Check3
Caption = "去除该表首行数据"
Height = 495
Left = 120
TabIndex = 24
Top = 960
Value = 1 'Checked
Width = 1815
End
Begin VB.TextBox TxtNum
Height = 270
Left = 1440
TabIndex = 17
Text = "2"
Top = 1560
Width = 495
End
Begin VB.CommandButton Command1
Caption = "添加表格"
Height = 375
Left = 240
TabIndex = 9
Top = 1980
Width = 1695
End
Begin VB.Label Label7
Caption = "本班对应学分:"
Height = 255
Left = 240
TabIndex = 16
Top = 1620
Width = 1335
End
End
Begin VB.Frame Frame2
Caption = "程序说明信息:"
Height = 2535
Left = 60
TabIndex = 7
Top = 960
Width = 9915
Begin VB.PictureBox MsgPic
Appearance = 0 'Flat
AutoRedraw = -1 'True
BorderStyle = 0 'None
FillColor = &H00404040&
ForeColor = &H80000008&
Height = 2175
Left = 120
ScaleHeight = 2175
ScaleWidth = 9495
TabIndex = 18
Top = 240
Width = 9495
End
End
Begin VB.Frame Frame1
Caption = "表格基本信息:"
Height = 735
Left = 60
TabIndex = 0
Top = 120
Width = 12135
Begin VB.CommandButton Command2
Caption = "确定设置"
Height = 375
Left = 10200
TabIndex = 23
Top = 240
Width = 1695
End
Begin VB.TextBox Text1
Height = 270
Index = 4
Left = 8400
TabIndex = 15
Text = "2004年12月30日"
Top = 320
Width = 1455
End
Begin VB.TextBox Text1
Height = 270
Index = 3
Left = 6600
TabIndex = 14
Text = "48"
Top = 320
Width = 495
End
Begin VB.TextBox Text1
Height = 270
Index = 2
Left = 4680
TabIndex = 13
Text = "第一学年"
Top = 320
Width = 975
End
Begin VB.TextBox Text1
Height = 270
Index = 1
Left = 2520
TabIndex = 12
Text = "化学1"
Top = 320
Width = 1335
End
Begin VB.TextBox Text1
Height = 270
Index = 0
Left = 840
TabIndex = 2
Text = "张聪"
Top = 320
Width = 855
End
Begin VB.Label Label5
Caption = "学分认定时间:"
Height = 255
Left = 7200
TabIndex = 6
Top = 360
Width = 1335
End
Begin VB.Label Label4
Caption = "学时数目:"
Height = 255
Left = 5760
TabIndex = 5
Top = 360
Width = 975
End
Begin VB.Label Label3
Caption = "学年度:"
Height = 255
Left = 3960
TabIndex = 4
Top = 360
Width = 735
End
Begin VB.Label Label2
Caption = "课程名:"
Height = 255
Left = 1800
TabIndex = 3
Top = 360
Width = 735
End
Begin VB.Label Label1
Caption = "教师名:"
Height = 255
Left = 120
TabIndex = 1
Top = 360
Width = 735
End
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'*******************************************************************************************
'作者信息:
'演示如何对EXCEL对象进行操作,往往对XLS文件的操作不需要DAO、ADO等,可以直接利用OFFICE来进行,
'当然这也有局限性:未安装MS EXCEL的计算机可能无法正常运行。代码未整理,一步一步写的,乱点儿。
'E-MAIL: shaoyan5@163.com
' 作者:张聪(ZCSOR)
' 于2006年9月18日
'*******************************************************************************************
Option Explicit
Private mDataPath As String
Private mTempPath As String
Private mTempFile As String
Private mTempStr As String
Private mXLS As String
Private Sub Check1_Click()
If Check1.Value Then TxtNum.Enabled = True Else TxtNum.Enabled = False
End Sub
Private Sub Command1_Click()
On Error GoTo mErr
'添加并处理数据
'设置打开对话框
XlsOpenCD.CancelError = True
XlsOpenCD.Flags = cdlOFNHideReadOnly
'将用户选定文件以备份方式打开
XlsOpenCD.ShowOpen
mTempFile = mTempPath & XlsOpenCD.FileTitle
For mIndex = LBound(mOpenFile) To UBound(mOpenFile)
Debug.Print mOpenFile(mIndex)
If mOpenFile(mIndex) = XlsOpenCD.FileName Then
If MsgBox(mTempFile & "已经添加,真的要重复添加吗?", vbYesNo, "表格已添加") = vbNo Then GoTo mErr:
End If
Next
Command1.Enabled = False
Command3.Enabled = False
Form1!Label6.Caption = "正在备份和打开表格……"
FileCopy XlsOpenCD.FileName, mTempFile
DoEvents
'打开用户选定文件,并处理数据后,添加到输出文件
Set aExcel = CreateObject("excel.application") '创建EXCEL应用程序对象,启动EXCEL应用程序
Set aBook = aExcel.Workbooks.Open(mTempFile) '打开工作薄,并将其赋给xbook
Set aSheet = aBook.Worksheets(1) '将xbook工作薄中的第一个表赋给xsheet
'Debug.Print aSheet.cells(1, 1), aSheet.cells(1, 2)
'寻找导入表终点
Form1!Label6.Caption = "正在查找表格内条目数……"
For mIndex = 1 To 4096
If aSheet.cells(mIndex, 1) = "" Then
aEofSheet = mIndex
Exit For
End If
Next
'将导入表内容输入到最终表
Form1!Label6.Caption = "正在将" & mTempFile & "内容导入到" & mXLS & "……"
If Check2.Value Then mNum = 1.5 Else mNum = 1
Dim mJz As Long
If Check3.Value Then mJz = 2 Else mJz = 1
mIndex = 0
If mEofSheet = 0 Then mEofSheet = 2
For mIndex = mJz To aEofSheet - 1
mSheet.cells(mEofSheet, 1) = aSheet.cells(mIndex, 1)
mSheet.cells(mEofSheet, 2) = aSheet.cells(mIndex, 2)
If Check1.Value Then
mSheet.cells(mEofSheet, 3) = mRnd(mIndex)
mSheet.cells(mEofSheet, 4) = TxtNum.Text
End If
mEofSheet = mEofSheet + 1
Next
aBook.Close
DoEvents
Set aSheet = Nothing
Set aBook = Nothing
Set aExcel = Nothing
ReDim Preserve mOpenFile(mOpenNum)
mOpenFile(mOpenNum) = XlsOpenCD.FileName
mOpenNum = mOpenNum + 1
Form1!Label6.Caption = "成功将" & mTempFile & "内容导入到" & mXLS & "中。"
XlsMsg XlsOpenCD.FileName & "———添加人数为:" & aEofSheet - 1
Command1.Enabled = True
Command3.Enabled = True
mErr:
Form1!Label6.Caption = "执行了取消操作,等待继续操作……"
Exit Sub
End Sub
Private Sub Command2_Click()
mOpenNum = 0
mEofSheet = 0
ReDim mOpenFile(mOpenNum)
For mIndex = 0 To 4
If Text1(mIndex).Text = "" Then
MsgBox "信息不完全"
Exit Sub
End If
Next
Command2.Enabled = False
'建立输出文件
mXLS = mDataPath
For mIndex = 0 To 4
mXLS = mXLS & Text1(mIndex).Text & "_"
mTempStr = mTempStr & Text1(mIndex).Text & "_"
Next
mXLS = mXLS & "xfxx.xls"
'建立一个新工作薄,用以存储合成后的数据.工作薄处于打开状态等待数据写入
If Not ConstructXls(mXLS) Then Exit Sub
'清除消息显示
MsgPic.Cls
XlsMsg "已填加的表格有,请自行观察是否重复:"
Frame2.Caption = " 添加表格信息:"
Label6.Caption = "生成表格操作完成"
Command1.Enabled = True
End Sub
Private Sub Command3_Click()
Frame2.Caption = " 程序说明信息:"
mMsg
'关闭工作薄
Form1!Label6.Caption = "正在关闭工作薄……"
mBook.save
mBook.Close
DoEvents
Set mSheet = Nothing
Set mBook = Nothing
Set mExcel = Nothing
Form1!Label6.Caption = "已经关闭工作薄。可以继续制定表格"
Command2.Enabled = True
Command1.Enabled = False
Command3.Enabled = False
If Check4.Value Then Shell "Rundll32.exe url.dll, FileProtocolHandler " & mXLS
If Check5.Value Then Shell "explorer.exe " & mDataPath
End Sub
Private Sub Form_Load()
'显示窗体消息
mMsg
'查询并建立相应目录
mDataPath = App.Path & "/示例数据库/"
mMDir mDataPath
mTempPath = App.Path & "/TEMP/"
mMDir mTempPath
'设置打开对话框过滤器
XlsOpenCD.Filter = "*.xls | *.xls"
Command1.Enabled = False
Command3.Enabled = False
SetLogo 101
End Sub
Public Sub mMDir(ByVal mPath As String)
'路径查询,如果不存在则建立目录
If Dir(mPath, vbDirectory) <> "." Then MkDir (mPath)
End Sub
Private Sub Form_Unload(Cancel As Integer)
On Error Resume Next
MsgBox "使用中发现问题请联系作者:" & vbCrLf & _
"E-MAIL: shaoyan5@163.com" & vbCrLf & _
" 开发者:张聪", vbOKOnly, "感谢使用"
Command3_Click
End Sub
Private Sub LogoPic_Click()
If Check4.Value Then Shell "Rundll32.exe url.dll, FileProtocolHandler http://blog.csdn.net/zcsor"
End Sub
Private Sub Text1_Click(Index As Integer)
Text1(Index).Text = ""
End Sub
'以下在模块1
'表格操作相关,这些其实应该写在窗体里,变量有很多是局部的。
Option Explicit
Public mExcel As Object, mBook As Object, mSheet As Object '成品表对象
Public aExcel As Object, aBook As Object, aSheet As Object '添加表对象
Public mEofSheet As Long '标志成品表最后一个单元格,已经有的单元格个数
Public aEofSheet As Long '标志添加表最后一个单元格,即本表所有的学生个数
Public mIndex As Long '用于循环
Public mNum As Single '代表分制
Public mOpenFile() As String '保存已经导入过的文件
Public mOpenNum As Long '保存已经导入的表的个数
'建立一个空的数据表格
Public Function ConstructXls(ByVal xlsPathName As String) As Boolean
On Error GoTo mErr
If Dir(xlsPathName) <> "" Then
If MsgBox("表格 " & xlsPathName & " 已存在,要删除它吗?" & vbCrLf & "注意:如果不删除将无法继续!", vbYesNo) = vbYes Then Kill xlsPathName Else Exit Function
End If
Form1!Label6.Caption = "正在建立工作薄和表格……"
Set mExcel = CreateObject("excel.application") '创建EXCEL应用程序对象,启动EXCEL应用程序
Set mBook = mExcel.Workbooks.Add '新建一个工作簿,并将其赋给mbook
Set mSheet = mBook.Worksheets(1) '将mbook工作薄中的第一个表赋给msheet
mBook.SaveAs (xlsPathName)
'x.Visible = True '让EXCEL可视
mSheet.Columns("A:A").ColumnWidth = 14 '调节第一列的宽度
mSheet.cells(1, 1) = "注册学号" '输入第一行的内容
mSheet.cells(1, 2) = "学生姓名"
mSheet.cells(1, 3) = "成绩"
mSheet.cells(1, 4) = "学分"
DoEvents
Form1!Label6.Caption = "正在向工作薄写入数据……"
ConstructXls = True
mErr:
If Err.Number = 70 Then
If MsgBox("表格 " & xlsPathName & "正在被使用,无法正确删除,要结束调用它的程序后继续吗?" & vbCrLf & "注意:如果选择“是”,将关闭全部的EXCEL程序", vbYesNo) = vbYes Then killEx xlsPathName Else Exit Function
End If
Resume Next
End Function
'随机分数函数,基本模拟了实际分数分布
Public Function mRnd(ByVal Index As Long) As Single
Dim upperbound As Long, lowerbound As Long
Dim tmp As Single
Randomize
upperbound = 100 - Index / (aEofSheet - Index) + (aEofSheet - Index)
lowerbound = 60 - Index / (aEofSheet - Index) + (aEofSheet - Index)
tmp = (upperbound - lowerbound + 1) * Rnd + lowerbound
Do While tmp < 60
tmp = tmp + (10 - 5 + 1) * Rnd + 5
Loop
Do While tmp > 99
tmp = tmp - (20 - 1 + 1) * Rnd - 1
Loop
Dim m5 As Single
If CInt(Mid(CStr(tmp), 5, 1)) > 8 Then m5 = 0.5
mRnd = (Int(tmp) + m5) * mNum
End Function
'窗体信息
Public Sub mMsg()
Form1!MsgPic.AutoRedraw = True
Form1!MsgPic.Cls
Form1!MsgPic.Print "说明〖单击“确定设置”后,该信息将消失;导入表为班主任填写完整学生信息后的表格,如:cxfb.xls〗"
Form1!MsgPic.Print "一、程序界面:"
Form1!MsgPic.Print " 1 、表格基本信息栏:其中每项都是必填内容,它们组成成品表表的名字(按提示设置即与要求相同)。"
Form1!MsgPic.Print " 2 、项目添加操作栏:这一栏的信息,对应你将打开的数据库在成品表中的设置,详细见以下说明:"
Form1!MsgPic.Print " ①成绩真实情况模拟:勾选后,生成的表中,将带有所有学生的成绩和学分"
Form1!MsgPic.Print " ②去除该表首行数据:勾选后,会将导入里第一行数据删除后导入最终表格(这不影响打开的原始表)"
Form1!MsgPic.Print " ③本班对应学分文本:选择“成绩真实情况”后可用,表示成品表中“学分”的数据(适应文理不同)"
Form1!MsgPic.Print "二、使用方法:"
Form1!MsgPic.Print " 1 、填写“表格基本信息”栏内容,确信无误后按下“确定设置”按钮。"
Form1!MsgPic.Print " 2 、在“项目添加操作”栏内填写相应内容,该栏内的设置,只对本次将要填加的表有效。确信无误后按下“" & vbCrLf & " 填加表格”按钮。"
Form1!MsgPic.Print " 3 、重复第 2步的操作,直到把所有要填加的表格填加完全,单击“编辑结束”按钮或“退出程序”按钮。"
End Sub
'表格操作信息
Public Sub XlsMsg(ByVal xlsPathName As String)
Form1!MsgPic.Print xlsPathName
End Sub
'结束所有EXCEL并删除文件
Public Sub killEx(ByVal xlsPathName As String)
TerminateExcel
Kill xlsPathName
End Sub
'以下在模块2
'程序非法结束时,EXCEL将继续运行并锁定文件,导致文件无法打开,查找进程表并结束EXCEL
Option Explicit
'======================用于查找进程和终止进程的API函数常数定义=====================
Private Declare Function CreateToolhelpSnapshot Lib "kernel32" Alias "CreateToolhelp32Snapshot" (ByVal lFlags As Long, ByVal lProcessID As Long) As Long
Private Declare Function ProcessFirst Lib "kernel32" Alias "Process32First" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function ProcessNext Lib "kernel32" Alias "Process32Next" (ByVal hSnapShot As Long, uProcess As PROCESSENTRY32) As Long
Private Declare Function TerminateProcess Lib "kernel32" (ByVal hProcess As Long, ByVal uExitCode As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, ByVal dwProcessId As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Const MAX_PATH As Integer = 260
Private Type PROCESSENTRY32
dwSize As Long
cntUsage As Long
th32ProcessID As Long
th32DefaultHeapID As Long
th32ModuleID As Long
cntThreads As Long
th32ParentProcessID As Long
pcPriClassBase As Long
dwFlags As Long
szExeFile As String * MAX_PATH
End Type
Const TH32CS_SNAPheaplist = &H1
Const TH32CS_SNAPPROCESS = &H2
Const TH32CS_SNAPthread = &H4
Const TH32CS_SNAPmodule = &H8
Const TH32CS_SNAPall = TH32CS_SNAPPROCESS + TH32CS_SNAPheaplist + TH32CS_SNAPthread + TH32CS_SNAPmodule
'查找全部进程,并结束所有EXCEL.EXE
Public Sub TerminateExcel()
Dim i As Long, lPid As Long
Dim Proc As PROCESSENTRY32
Dim hSnapShot As Long
Dim lPHand As Long, TMBack As Long
hSnapShot = CreateToolhelpSnapshot(TH32CS_SNAPall, 0) '获得进程“快照”的句柄
Proc.dwSize = Len(Proc)
lPid = ProcessFirst(hSnapShot, Proc) '获取第一个进程的PROCESSENTRY32结构信息数据
i = 0
Do While lPid <> 0 '当返回值非零时继续获取下一个进程
If InStr(1, UCase(Proc.szExeFile), "EXCEL.EXE") Then
lPHand = Proc.th32ProcessID
lPHand = OpenProcess(1&, True, lPHand) '获取进程句柄
TMBack = TerminateProcess(lPHand, 0&) '关闭进程
CloseHandle lPHand
End If
i = i + 1
lPid = ProcessNext(hSnapShot, Proc) '循环获取下一个进程的PROCESSENTRY32结构信息数据
Loop
CloseHandle hSnapShot '关闭进程“快照”句柄
End Sub
'以下在模块3
'资源文件操作模块
Option Explicit
Public Sub SetLogo(ByVal ResID As Long)
Form1!LogoPic.Picture = LoadResPicture(ResID, 0)
End Sub
资源文件就不提供了,下载完整版本可以去下载区里面:常用软件---数据库类
具体地址:
(尚未审核,发布后地指会贴在这里,或去http://download.csdn.net/app/morefile.php?user=zcsor进行下载)
下载地址:
http://down.csdn.net/html/2006-09/18/159306.html
以上代码中存在一些问题,下载后请在COMMAND3的CLICK事件中添加mEofSheet = 0 一句,具体见上面。该句修复了第2次建立表格时表格位置的问题,另外,代码中随即成绩除存在严重BUG,导致运行失败;代码中弹出对话框(特别是添加表对话框)后,若点取消,将导致程序无法继续使用的严重BUG。以上3个问题已经修复,进行较全面测试后,将把更新帮本发到下载区,感谢大家的关注。希望大家能把发现的问题通过E-MAIL发给我,因为是我自己开发,没有很多测试机会,需要大家共同完善,当然,完善后的代码会随软件一同发布。感谢大家的支持,我的MAIL:shaoyan5@163.com
该代码还存在其他BUG,以及使用时不是很顺手的问题,在下一版本会修正。
代码不再在这里发了,可以去http://download.csdn.net/app/morefile.php?user=zcsor查看是否更新。