'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
