VB中操作EXECL表格（不使用AOD、DAO等）
介紹如何利用EXCEL對象操作.XLS文件，而不使用DAO等。下面是一個示例代碼，昨天寫的，是高中學分評定的一個輔助工具，可以把班主任做好的表里面的學號和姓名都弄過來并自動添加對應學分：）以上這些都是固定的啦，用起來省去不少工夫，當然了，這里主要是介紹VB中用EXCEL操作XLS文件，不討論在EXCEL里直接用VBA實現(xiàn)的問題~~~；還有一個提供“模板”的功能：把學生的分數(shù)用一個模擬函數(shù)同時輸入進去，這個功能大家不要用來作弊哦~~~自己學生的成績還是要自己一個一個填的才對的起學生麻！而且那個模擬函數(shù)，說實在的，就是簡單寫了幾句，模擬的情況并不是很好啦~~~
下面看代碼：(工程中除必須引用對象外沒有對任何對象進行引用,在FORM1里面名字為XlsOpenCD的是一個commandDialog控件,如果測試時提示找不到,請將其刪除并填加commandDialog控件,將其命名為XlsOpenCD)
注意：代碼由一個窗體（FORM1）和三個模塊及一個資源文件組成；你復制下來后直接測試會提示錯誤的，把FORM_LOAD事件里面對模塊3中SetLogo函數(shù)的調用注釋掉就可以啦。代碼寫的倉促，沒有整理，但是要介紹的EXCEL對象基本介紹清楚了。（簡述一下思路：建立一個表格文件并保持打開狀態(tài)，打開要填加的表格，獲取相應數(shù)據(jù)后加入建立的表格中，關閉打開的表格，關閉建立的表格。）
'以下復制后保存為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 = "去除該表首行數(shù)據(jù)"
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 = "學時數(shù)目："
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
'添加并處理數(shù)據(jù)
'設置打開對話框
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 & "已經(jīng)添加，真的要重復添加嗎？", vbYesNo, "表格已添加") = vbNo Then GoTo mErr:
End If
Next
Command1.Enabled = False
Command3.Enabled = False
Form1!Label6.Caption = "正在備份和打開表格……"
FileCopy XlsOpenCD.FileName, mTempFile
DoEvents
'打開用戶選定文件,并處理數(shù)據(jù)后,添加到輸出文件
Set aExcel = CreateObject("excel.application") '創(chuàng)建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 = "正在查找表格內條目數(shù)……"
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 & "———添加人數(shù)為：" & aEofSheet - 1
Command1.Enabled = True
Command3.Enabled = True
mErr:
Form1!Label6.Caption = "執(zhí)行了取消操作，等待繼續(xù)操作……"
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"
'建立一個新工作薄,用以存儲合成后的數(shù)據(jù).工作薄處于打開狀態(tài)等待數(shù)據(jù)寫入
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 = "已經(jīng)關閉工作薄。可以繼續(xù)制定表格"
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 & "\示例數(shù)據(jù)庫\"
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 "使用中發(fā)現(xiàn)問題請聯(lián)系作者:" & vbCrLf & _
"E-MAIL:
shaoyan5@163.com" & vbCrLf & _
" 開發(fā)者：張聰", vbOKOnly, "感謝使用"
Command3_Click
End Sub
Private Sub LogoPic_Click()
If Check4.Value Then Shell "Rundll32.exe url.dll, FileProtocolHandler
End SubPrivate 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 '標志成品表最后一個單元格,已經(jīng)有的單元格個數(shù)
Public aEofSheet As Long '標志添加表最后一個單元格,即本表所有的學生個數(shù)
Public mIndex As Long '用于循環(huán)
Public mNum As Single '代表分制
Public mOpenFile() As String '保存已經(jīng)導入過的文件
Public mOpenNum As Long '保存已經(jīng)導入的表的個數(shù)
'建立一個空的數(shù)據(jù)表格
Public Function ConstructXls(ByVal xlsPathName As String) As Boolean
On Error GoTo mErr
If Dir(xlsPathName) <> "" Then
If MsgBox("表格 " & xlsPathName & " 已存在,要刪除它嗎?" & vbCrLf & "注意:如果不刪除將無法繼續(xù)!", vbYesNo) = vbYes Then Kill xlsPathName Else Exit Function
End If
Form1!Label6.Caption = "正在建立工作薄和表格……"
Set mExcel = CreateObject("excel.application") '創(chuàng)建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 '調節(jié)第一列的寬度
mSheet.cells(1, 1) = "注冊學號" '輸入第一行的內容
mSheet.cells(1, 2) = "學生姓名"
mSheet.cells(1, 3) = "成績"
mSheet.cells(1, 4) = "學分"
DoEvents
Form1!Label6.Caption = "正在向工作薄寫入數(shù)據(jù)……"
ConstructXls = True
mErr:
If Err.Number = 70 Then
If MsgBox("表格 " & xlsPathName & "正在被使用,無法正確刪除,要結束調用它的程序后繼續(xù)嗎?" & vbCrLf & "注意:如果選擇“是”，將關閉全部的EXCEL程序", vbYesNo) = vbYes Then killEx xlsPathName Else Exit Function
End If
Resume Next
End Function
'隨機分數(shù)函數(shù),基本模擬了實際分數(shù)分布
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 、項目添加操作欄：這一欄的信息，對應你將打開的數(shù)據(jù)庫在成品表中的設置，詳細見以下說明："
Form1!MsgPic.Print " ①成績真實情況模擬：勾選后，生成的表中，將帶有所有學生的成績和學分"
Form1!MsgPic.Print " ②去除該表首行數(shù)據(jù)：勾選后，會將導入里第一行數(shù)據(jù)刪除后導入最終表格（這不影響打開的原始表）"
Form1!MsgPic.Print " ③本班對應學分文本：選擇“成績真實情況”后可用，表示成品表中“學分”的數(shù)據(jù)（適應文理不同）"
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將繼續(xù)運行并鎖定文件,導致文件無法打開,查找進程表并結束EXCEL
Option Explicit
'======================用于查找進程和終止進程的API函數(shù)常數(shù)定義=====================
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結構信息數(shù)據(jù)
i = 0
Do While lPid <> 0 '當返回值非零時繼續(xù)獲取下一個進程
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) '循環(huán)獲取下一個進程的PROCESSENTRY32結構信息數(shù)據(jù)
Loop
CloseHandle hSnapShot '關閉進程“快照”句柄
End Sub
'以下在模塊3
'資源文件操作模塊
Option Explicit
Public Sub SetLogo(ByVal ResID As Long)
Form1!LogoPic.Picture = LoadResPicture(ResID, 0)
End Sub
資源文件就不提供了,下載完整版本可以去下載區(qū)里面:常用軟件---數(shù)據(jù)庫類
具體地址：
下載地址：
以上代碼中存在一些問題，下載后請在COMMAND3的CLICK事件中添加mEofSheet = 0 一句，具體見上面。該句修復了第2次建立表格時表格位置的問題，另外，代碼中隨即成績除存在嚴重BUG，導致運行失??；代碼中彈出對話框（特別是添加表對話框）后，若點取消，將導致程序無法繼續(xù)使用的嚴重BUG。以上3個問題已經(jīng)修復，進行較全面測試后，將把更新幫本發(fā)到下載區(qū)，感謝大家的關注。希望大家能把發(fā)現(xiàn)的問題通過E-MAIL發(fā)給我，因為是我自己開發(fā)，沒有很多測試機會，需要大家共同完善，當然，完善后的代碼會隨軟件一同發(fā)布。感謝大家的支持，我的MAIL：
shaoyan5@163.com該代碼還存在其他BUG，以及使用時不是很順手的問題，在下一版本會修正。
