一组有用的操作Excel的函数 (转)

一组有用的操作Excel的函数 (转)[@more@]

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

 

这上面的函数只不过是一部分,其于的因为专用目的,写不标准,以后也许会整理出来一份标准的函数库的!

Mailto:w.hua@ynmail.com">w.hua@ynmail.com

来自 “ ITPUB博客 ” ，链接：http://blog.itpub.net/10752043/viewspace-990099/，如需转载，请注明出处，否则将追究法律责任。

转载于:http://blog.itpub.net/10752043/viewspace-990099/