在用VB做程序的时候,它本身的报表并不太好使用,因此应用Excel输出数据,是一个好方法,以下是一组操纵Excel的函数据,希望能帮助大家.
'Excel VBA控制函数
'Write By WeiHua 2000.10.12
'检测文件Function CheckFile(ByVal strFile As String) As BooleanDim FileXls As ObjectSet 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 BooleanDim L As IntegerDim 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 = FalseEnd 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 BooleanDim 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 BooleanDim i As IntegerDim 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 BooleanDim xlSrcBook As Excel.WorkbookDim xlTagBook As Excel.WorkbookDim ExcelSource As Excel.WorksheetDim ExcelTarget As Excel.WorksheetDim Result As Boolean
If CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False ThenSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = False Exit FunctionElse
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 = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = TrueEnd IfEnd Function'复制工作表Function ExcelCopySheet(ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As BooleanDim xlSrcBook As Excel.WorkbookDim xlTagBook As Excel.WorkbookDim ExcelSource As Excel.WorksheetDim ExcelTarget As Excel.WorksheetDim Result As Boolean
If CheckFile(strSrcWorkBook) = False Or CheckFile(strTagWorkbook) = False ThenSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = False Exit FunctionElse
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 = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = TrueEnd IfEnd Function
'关闭Excel应用Function CloseExcelApp(xlApp As Object)On Error Resume NextxlApp.QuitSet xlApp = NothingEnd Function
'建立Excel应用Function CreateExcelApp(QuitApp As Boolean) As ObjectOn Error Resume NextDim xlObject As ObjectIf CheckExcel Then
Set xlObject = GetObject(, "Excel.Application")If err.Number <> 0 Then Set xlObject = Nothing Set xlObject = CreateObject("Excel.Application") CreateExcelApp = xlObjectElse If QuitApp Then xlObject.Quit Set xlObject = Nothing Set xlObject = CreateObject("Excel.Application") End If CreateExcelApp = xlObjectEnd If
End If
End Function
'检测EXCEL环境Function CheckExcel() As BooleanDim xlCheckApp As ObjectSet 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 IfEnd 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 FunctionFunction GetPath(strPath As String) As StringGetPath = IIf(Len(strPath) = 3, strPath, strPath & "/")End Function
这上面的函数只不过是一部分,其于的因为专用目的,写不标准,以后也许会整理出来一份标准的函数库的!
w.hua@ynmail.com
