When using VB to do programs, its own report is not very easy to use, so applying Excel output data is a good way. The following is a group of letter data that manipulates Excel, I hope to help everyone.
'Excel VBA Control Function
'Write by Weihua 2000.10.12
'Detection File Function Checkfile (BYVAL STRFILE AS STRING) AS Booleandim Filexls As ObjectSet Filexls = CreateObject ("scripting.filesystemObject")
If isnull (strfile) or strfile = "" "THECKFILE = 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 'detected worksheet Function CheckSheet (ByVal strSheet As String, ByVal strWorkBook As String, xlCheckApp As Excel.Application) AS Booleandim L AS IntegerDim 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 "Worksheet does not exist, may be caused by file names or work delegations!" Checksheet = false
END FUNCTION
'Create Worksheet' CreateMethod: 1 Append 'CreateMethod: 2 covering Function CreateSheet (ByVal strSheetName As String, ByVal strWorkBook As String, ByVal CreateMethod As Integer, xlCreateApp As Excel.Application) As BooleanDim xlCreateSheet As Excel.WorksheetIf 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 & "worksheet already exists!" 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 . Elect Xlcreatesheet.cells.Delete XlcreateApp.ActiveWorkbook.save Createsheet = true set xlcreatesheet = Nothing else 'msgbox strsheetname & "Worksheet does not exist! "Createsheet = false set xlcreatesheet = Nothing end if end if Endiff
End Function 'Delete Sheet Function DeleteSheet (ByVal strSheetName As String, ByVal strWorkBook As String, xlDeleteApp As Excel.Application) As BooleanDim i As IntegerDim 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 "workbook can not remove all," & strSheetName & "is the last sheet!" DeleteSheet = False Exit Function End If xlDeleteApp.Worksheets (strsheetname). deletexldeleteapp.activeworkbook.save deleteSheet = true else deleteSheet = false end if endiff
END FUNCTION
'Copy sheet Function CopySheet (ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As BooleanDim xlSrcBook As Excel.WorkbookDim xlTagBook As Excel.WorkbookDim ExcelSource As Excel.WorksheetDim ExcelTarget As Excel.Worksheetdim Result As Boolean
If CheckFile (strSrcWorkBook) = False Or CheckFile (strTagWorkbook) = False ThenSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = False Exit FunctionElse
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 = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = TrueEnd IfEnd Function 'copy sheet Function ExcelCopyS heet (ByVal strSrcSheetName As String, ByVal strSrcWorkBook As String, ByVal strTagSheetName As String, ByVal strTagWorkbook As String, xlCopyApp As Excel.Application) As BooleanDim xlSrcBook As Excel.WorkbookDim xlTagBook As Excel.WorkbookDim ExcelSource As Excel.WorksheetDim ExcelTarget As Excel.WorksheetDim Result as boolean
If CheckFile (strSrcWorkBook) = False Or CheckFile (strTagWorkbook) = False ThenSet ExcelSource = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = False Exit FunctionElse
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 = NothingSet ExcelTarget = NothingSet xlSrcBook = NothingSet xlTagBook = Nothing CopySheet = TrueEnd IfEnd Function
'Close Excel Application Function CloseExcelapp (XLAPP As Object) ON Error ResMe nextxlapp.quitset XLAPP = Nothingend Function
'Establishing Excel App Function CreateExcelapp (QuitApp As Boolean) AS Objecton Error Resume Nextdim Xlobject As Objectif CHECKEXCEL THEN
Set xlObject = GetObject (, "Excel.Application") If err.Number <> 0 Then Set xlObject = Nothing Set xlObject = CreateObject ( "Excel.Application") CreateExcelApp = xlObjectElse If QuitApp Then xlObject.Quit Set xlObject = Nothing Set xlObject = CreateObject ("Excel.Application") end if createExcelapp = xlobjectEnd IF
END IF
END FUNCTION
'Detection EXCEL environment Function CheckExcel () As BooleanDim xlCheckApp As ObjectSet xlCheckApp = CreateObject ( "Excel.Application") If xlCheckApp Is Nothing Then MsgBox "Sorry, the system does not detect the installation EXCEL, EXCEL re-check whether the installed correctly!" CheckExcel = False xlcheckapp.quit set xlcheckapp = Nothing exit function else xlcheckapp.quit checkexcel = true set xlcheckapp = Nothing end ifend 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 functionFunction getPath (strPath as string) AS stringgetpath = IIF (Len (strpath) = 3, strpath, strpath & ") end function
The above functions are only part of it, which is due to dedicated purposes, written in standard, will be organized out of a standard library in the future!
w.hua@ynmail.com
