一組有用的操作Excel的函數

在用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

這上面的函數只不過是一部分,其于的因為專用目的,寫不標準,以后也許會整理出來一份標準的函數庫的!

w.hua@ynmail.com