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

[1] [2] 下一页