以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