以VB操作EXCEL(转贴)

'在用VB做程序的时候,它本身的报表并不太好使用,因此应用Excel输出数据,是一个好方法,以下是一组操纵Excel的函数据.




'Excel VBA控制函数




'检测文件




Function CheckFile()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()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()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()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()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()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()Function CloseExcelApp(xlApp As Object)


On Error Resume Next


xlApp.Quit


Set xlApp = Nothing


End Function




'建立Excel应用




Function CreateExcelApp()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()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()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()Function GetPath(strPath As String) As String


GetPath = IIf(Len(strPath) = 3, strPath, strPath & "")


End Function