在用VB做程序的時候,它本身的報表并不太好使用,因此應用Excel輸出數據,是一個好方法,以下是一組操縱Excel的函數據,希望能幫助大家.
'Excel VBA控制函數
'Write By WeiHua 2000.10.12
'檢測文件
Function CheckFile(ByVal strFile As String) As Boolean
Dim FileXls As Object
Set FileXls = CreateObject("Scripting.FileSystemObject")
If IsNull(strFile) Or strFile = "" Then
CheckFile = False
Exit Function
End If
If FileXls.FileExists(strFile) = False Then
CheckFile = False
Set FileXls = Nothing
Exit Function
Else
CheckFile = True
Set FileXls = Nothing
End If
End Function
'檢測工作表
Function CheckSheet(ByVal strSheet As String, ByVal strWorkBook As String, xlCheckApp As Excel.Application) As Boolean
Dim L As Integer
Dim CheckWorkBook As Excel.Workbook
If CheckFile(strWorkBook) And strSheet <> "" And Not IsNull(strSheet) Then
For L = 1 To xlCheckApp.Workbooks.Count
If GetPath(xlCheckApp.Workbooks(L).Path) & xlCheckApp.Workbooks(L).Name = strWorkBook Then
Set CheckWorkBook = xlCheckApp.Workbooks(L)
Exit For
End If
Next L
Set CheckWorkBook = xlCheckApp.Workbooks.Open(strWorkBook)
For L = 1 To CheckWorkBook.Worksheets.Count
If CheckWorkBook.Worksheets(L).Name = Trim(strSheet) Then
CheckSheet = True
Exit For
End If
Next L
Else
MsgBox "工作表不存在,可能是由文件名或工作表名引起的!"
CheckSheet = False
End If
End Function
'建立工作表
'CreateMethod:1追加
'CreateMethod:2覆蓋
Function CreateSheet(ByVal strSheetName As String, ByVal strWorkBook As String, ByVal CreateMethod As Integer, xlCreateApp As Excel.Application) As Boolean
Dim xlCreateSheet As Excel.Worksheet
If CheckFile(strWorkBook) Then
xlCreateApp.Workbooks.Open (strWorkBook)
If CreateMethod = 1 Then
If CheckSheet(strSheetName, strWorkBook, xlCreateApp) = False Then
Set xlCreateSheet = xlCreateApp.Worksheets.Add
xlCreateSheet.Name = strSheetName
xlCreateApp.ActiveWorkbook.Save
CreateSheet = True
Set xlCreateSheet = Nothing
Else
'MsgBox strSheetName & "工作表已存在!"
CreateSheet = False
Set xlCreateSheet = Nothing
End If
ElseIf CreateMethod = 2 Then
If CheckSheet(strSheetName, strWorkBook, xlCreateApp) = True Then
Set xlCreateSheet = xlCreateApp.Worksheets(strSheetName)
xlCreateSheet.Cells.Select
xlCreateSheet.Cells.Delete
xlCreateApp.ActiveWorkbook.Save
CreateSheet = True
Set xlCreateSheet = Nothing
Else
'MsgBox strSheetName & "工作表不存在!"
CreateSheet = False
Set xlCreateSheet = Nothing
End If
End If
End If
End Function
'刪除工作表
Function DeleteSheet(ByVal strSheetName As String, ByVal strWorkBook As String, xlDeleteApp As Excel.Application) As Boolean
Dim i As Integer
Dim xlDeleteSheet As Excel.Worksheet
If CheckFile(strWorkBook) Then
If CheckSheet(strSheetName, strWorkBook, xlDeleteApp) = True Then
xlDeleteApp.Workbooks.Open (strWorkBook)
If xlDeleteApp.Worksheets.Count = 1 Then
MsgBox "工作薄不能全部刪除," & strSheetName & "是最后一個工作表!"
DeleteSheet = False
Exit Function
End If
xlDeleteApp.Worksheets(strSheetName).Delete
xlDeleteApp.ActiveWorkbook.Save
DeleteSheet = True
Else
DeleteSheet = False
End If
End If
End Function
'復制工作表
Function CopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As Boolean
Dim xlSrcBook As Excel.Workbook
Dim xlTagBook As Excel.Workbook
Dim ExcelSource As Excel.Worksheet
Dim ExcelTarget As Excel.Worksheet
Dim Result As Boolean
If CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
CopySheet = False
Exit Function
Else
Set xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)
If strSrcWorkBook = strTagWorkbook Then
If strSrcSheetName = strTagSheetName Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
CopySheet = False
Exit Function
End If
Set xlTagBook = xlSrcBook
Else
Set xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)
End If
Set ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)
Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)
ExcelSource.Select
ExcelSource.Cells.Copy
ExcelTarget.Select
ExcelTarget.Paste
xlCopyApp.Application.CutCopyMode = xlCopy
If strSrcWorkBook = strTagWorkbook Then
xlTagBook.Save
xlSrcBook.Save
Else
xlTagBook.Save
End If
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
CopySheet = True
End If
End Function
'復制工作表
Function ExcelCopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As Boolean
Dim xlSrcBook As Excel.Workbook
Dim xlTagBook As Excel.Workbook
Dim ExcelSource As Excel.Worksheet
Dim ExcelTarget As Excel.Worksheet
Dim Result As Boolean
If CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
CopySheet = False
Exit Function
Else
Set xlSrcBook = xlCopyApp.Workbooks.Open(strSrcWorkBook)
If strSrcWorkBook = strTagWorkbook Then
If strSrcSheetName = strTagSheetName Then
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
CopySheet = False
Exit Function
End If
Set xlTagBook = xlSrcBook
Else
Set xlTagBook = xlCopyApp.Workbooks.Open(strTagWorkbook)
End If
Set ExcelSource = xlSrcBook.Worksheets(strSrcSheetName)
Set ExcelTarget = xlTagBook.Worksheets(strTagSheetName)
ExcelSource.Select
ExcelSource.Copy before
ExcelTarget.Select
ExcelTarget.Paste
xlCopyApp.Application.CutCopyMode = xlCopy
If strSrcWorkBook = strTagWorkbook Then
xlTagBook.Save
xlSrcBook.Save
Else
xlTagBook.Save
End If
Set ExcelSource = Nothing
Set ExcelTarget = Nothing
Set xlSrcBook = Nothing
Set xlTagBook = Nothing
CopySheet = True
End If
End Function
'關閉Excel應用
Function CloseExcelApp(xlApp As Object)
On Error Resume Next
xlApp.Quit
Set xlApp = Nothing
End Function
'建立Excel應用
Function CreateExcelApp(QuitApp As Boolean) As Object
On Error Resume Next
Dim xlObject As Object
If CheckExcel Then
Set xlObject = GetObject(, "Excel.Application")
If err.Number <> 0 Then
Set xlObject = Nothing
Set xlObject = CreateObject("Excel.Application")
CreateExcelApp = xlObject
Else
If QuitApp Then
xlObject.Quit
Set xlObject = Nothing
Set xlObject = CreateObject("Excel.Application")
End If
CreateExcelApp = xlObject
End If
End If
End Function
'檢測EXCEL環境
Function CheckExcel() As Boolean
Dim xlCheckApp As Object
Set xlCheckApp = CreateObject("Excel.Application")
If xlCheckApp Is Nothing Then
MsgBox "對不起,系統未檢測到EXCEL安裝,請重新檢查EXCEL是否被正確安裝!"
CheckExcel = False
xlCheckApp.Quit
Set xlCheckApp = Nothing
Exit Function
Else
xlCheckApp.Quit
CheckExcel = True
Set xlCheckApp = Nothing
End If
End Function
Function CreateWorkBook(ByVal strWorkBook As String, xlApp As Excel.Application)
Dim xlCreateWorkBook As Excel.Workbook
Set xlCreateWorkBook = xlApp.Workbooks.Add
xlCreateWorkBook.SaveAs (strWorkBook)
End Function
Function GetPath(strPath As String) As String
GetPath = IIf(Len(strPath) = 3, strPath, strPath & "\")
End Function
這上面的函數只不過是一部分,其于的因為專用目的,寫不標準,以后也許會整理出來一份標準的函數庫的!
原文轉自:http://www.anti-gravitydesign.com