Home |
Search |
Today's Posts |
#1
![]()
Posted to microsoft.public.excel.programming
|
|||
|
|||
![]()
I have an older windows service program written in VB6 that uses CreateObject
to automate the excel application object and do the following: ~ Read a csv file ~ Open the installed Excel application on a server ~ Load a workbook that is used like a template. ~ Copy data from the csv file into a target data sheet in the template workbook. ~ Run a named macro on the data loaded template ~ Save the data loaded and transformed file as a new file All of this works great with Office 2003 up to service pack 2. I have to register my service so that it runs under a specific user account, but otherwise there are no issues. However once I upgrade to Excel 2003 sp3 or greater, not to mention 2007, the create object call no longer works. I cannot create the application object unless VBA is disabled, and if VBA is disabled, I cannot run the transformational macros. I am assuming that it is a security setup issue that is stopping my code from working properly. If anyone can shed some light on how to get around this problem I would be most greatful. Here is my vb code: Private Function CSVToExcel(a_strPlanName As String, a_strRepository As String, a_intBatchID As Long, a_strPath As String, ByRef a_strError As String) As Boolean '//////////////////////////////////////////////////////////// '// Purpose: '// Gather data from a delimited text file, dump it into '// An excel template and save the results. '//////////////////////////////////////////////////////////// '// Created 5/24/2006 by David Cohen for MedInitiatives '//////////////////////////////////////////////////////////// '// Modified 9/14/2006 by david cohen - Added code to determine the exact amount of data in the data sheet. Rather than using '// the DataRangeEnd value to approximate. '//////////////////////////////////////////////////////////// On Error GoTo Catch Dim l_rs As Recordset Dim oExcel As Object Dim oTemplate As Object Dim oData As Object Dim oDataSheet As Object Dim oTemplateSheet As Object Dim mystream As ADODB.Stream Dim l_FSO As FileSystemObject Dim retval As Variant Dim l_strErr As String Dim l_strPlanName As String Dim l_strDebug As TextStream Dim l_intErr As Integer Dim lastrow As Integer Dim lastcol As Integer Dim l_strData As TextStream Dim l_lngDataLineCount As Long '// Set the file system object Set l_FSO = New FileSystemObject Set l_strDebug = l_FSO.OpenTextFile("C:\Batch\CSVToExcelDebug.txt", ForAppending, True) l_intErr = 1 l_strDebug.WriteLine l_intErr & ": Processing Batch ID: " & a_intBatchID & ". Create and Set the type of the ADO Stream." '// Create a new stream object to retrieve the excel template Set mystream = New ADODB.Stream mystream.Type = adTypeBinary l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 2 l_strDebug.WriteLine l_intErr & ": Set the recordset and select the template row." '// Get the template and data associated with this excel file Set l_rs = New ADODB.Recordset l_rs.Open "Select * from is_ExcelTemplate where PlanName = '" & a_strPlanName & "'", m_connSys, adOpenStatic, adLockOptimistic l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 3 '// Stream the file to the temp area l_strDebug.WriteLine l_intErr & ": Open the stream and get the template." mystream.Open If Not l_rs!CSVExportFlag Then If Not IsNull(l_rs!Template) Then mystream.Write l_rs!Template Else '// If this process fails we have a problem. CSVToExcel = False l_strErr = "No Excel Template Data passed." GoTo Catch End If End If l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 4 l_strDebug.WriteLine l_intErr & ": Remove any unacceptable characters from the filename and save the template." '// Remove any unacceptable characters from the filename l_strPlanName = Replace(a_strPlanName, "*", "_") l_strPlanName = Replace(l_strPlanName, "/", "_") l_strPlanName = Replace(l_strPlanName, "\", "_") l_strPlanName = Replace(l_strPlanName, "|", "_") l_strPlanName = Replace(l_strPlanName, "<", "_") l_strPlanName = Replace(l_strPlanName, "", "_") l_strPlanName = Replace(l_strPlanName, ":", "_") '// Save the template On Error Resume Next mystream.SaveToFile a_strPath & "\" & l_strPlanName & ".xls", adSaveCreateOverWrite If Err.Number = 3004 Then If l_FSO.FileExists(a_strPath & "\" & l_strPlanName & ".xls") Then l_strDebug.WriteLine l_intErr & ": Error reported but file exists. Disregarding error." Else GoTo Catch End If End If On Error GoTo Catch l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 5 l_strDebug.WriteLine l_intErr & ": Open the excel application object." '// Open Excel On Error GoTo NoExcel Set oExcel = CreateObject("Excel.Application") On Error GoTo Catch l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 6 l_strDebug.WriteLine l_intErr & ": Setting options on excel application object." oExcel.AlertBeforeOverwriting = False oExcel.AskToUpdateLinks = False oExcel.DisplayAlerts = False l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 7 l_strDebug.WriteLine l_intErr & ": Open the csv in memory. Count the rows." '// Find out how many rows are in the data file Set l_strData = l_FSO.OpenTextFile(a_strPath & "\" & a_intBatchID & ".csv", ForReading, False) Do Until l_strData.AtEndOfStream l_strData.SkipLine Loop l_lngDataLineCount = l_strData.line l_strData.Close If l_lngDataLineCount = 0 Then l_lngDataLineCount = 1 If l_lngDataLineCount 65536 Then l_lngDataLineCount = 65530 l_strDebug.WriteLine l_intErr & ": Too much data, " & l_lngDataLineCount & " rows returned. Too much to put in excel. Data Truncated at 65,530 rows." Else l_strDebug.WriteLine l_intErr & ": Successful, less than 65,536 rows." End If l_intErr = 8 l_strDebug.WriteLine l_intErr & ": Open the template and csv in excel." '// Open the template Set oTemplate = oExcel.Workbooks.Open(a_strPath & "\" & l_strPlanName & ".xls") '// Open the data csv Set oData = oExcel.Workbooks.Open(a_strPath & "\" & a_intBatchID & ".csv") l_strDebug.WriteLine l_intErr & ": Successful" l_intErr = 9 l_strDebug.WriteLine l_intErr & ": Get the data sheet into a variable." '// Get the sheets we need l_strDebug.WriteLine l_intErr & ": Trying to get data sheet " & a_intBatchID & " into a data variable." Set oDataSheet = oData.Worksheets(CStr(a_intBatchID)) l_strDebug.WriteLine l_intErr & ": Trying to get template data sheet " & l_rs!DataSheetName & " into a variable." Set oTemplateSheet = oTemplate.Worksheets(CStr(l_rs!DataSheetName)) l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 10 l_strDebug.WriteLine l_intErr & ": Copy the data into the template." '// Copy the data into the template oDataSheet.Activate oDataSheet.Range("A1", CStr(l_rs!DataRangeEnd & l_lngDataLineCount)).Copy oTemplateSheet.Range(CStr(l_rs!TargetDataStart)) l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 11 l_strDebug.WriteLine l_intErr & ": Save Results to a new File." '// Save the results oTemplate.SaveCopyAs a_strPath & "\" & a_intBatchID & ".xls" oData.Close SaveChanges:=False oTemplate.Close SaveChanges:=False Set oTemplate = Nothing l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 12 l_strDebug.WriteLine l_intErr & ": Open new file and run macros if there are any." '// Reopen the file and run any macros If Not IsNull(l_rs!MacroName) Then If Not Len(l_rs!MacroName) = 0 Then Set oTemplate = oExcel.Workbooks.Open(CStr(a_strPath & "\" & a_intBatchID & ".xls")) l_strErr = "Attempting to run macro, " & l_rs!MacroName & "." retval = oTemplate.Application.Run(CStr(l_rs!MacroName)) If retval = 0 Then l_strErr = "Error running macro '" & l_rs!MacroName & "' in template '" & a_strPlanName & "'." GoTo Catch End If oTemplate.Close SaveChanges:=True End If End If l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 13 l_strDebug.WriteLine l_intErr & ": Clean up objects." Set oData = Nothing Set oTemplate = Nothing Set oExcel = Nothing Set oDataSheet = Nothing Set oTemplateSheet = Nothing l_strDebug.WriteLine l_intErr & ": Successful." l_intErr = 14 l_strDebug.WriteLine l_intErr & ": Delete work files." '// Delete the template Call l_FSO.DeleteFile(a_strPath & "\" & a_strPlanName & ".xls") '// Delete the data file Call l_FSO.DeleteFile(a_strPath & "\" & a_intBatchID & ".csv") l_strDebug.WriteLine l_intErr & ": Successful." l_strDebug.Close Set l_strDebug = Nothing Set l_FSO = Nothing CSVToExcel = True Exit Function NoExcel: l_strErr = "Excel Application object could not be created! Excel Not Installed!" Catch: l_strDebug.WriteLine "Line: " & l_intErr & " - Error. " & Err.Number & " - " & Err.Description l_strDebug.Close If l_lngDataLineCount 65000 Then a_strError = "Error: Rowcount exceeded 65000." Else a_strError = l_intErr & " - Error. " & Err.Number & " - " & Err.Description End If Set l_strDebug = Nothing If l_FSO.FileExists(a_strPath & "\" & a_strPlanName & ".xls") Then '// Delete the template Set oTemplateSheet = Nothing Call l_FSO.DeleteFile(a_strPath & "\" & a_strPlanName & ".xls") End If '// Delete the data file If l_FSO.FileExists(a_strPath & "\" & a_intBatchID & ".csv") Then Call l_FSO.DeleteFile(a_strPath & "\" & a_intBatchID & ".csv") End If '// Delete the failed output file If l_FSO.FileExists(a_strPath & "\" & a_intBatchID & ".xls") Then Call l_FSO.DeleteFile(a_strPath & "\" & a_intBatchID & ".xls") End If CSVToExcel = False Set oData = Nothing Set oTemplate = Nothing Set oExcel = Nothing Set oDataSheet = Nothing Set oTemplateSheet = Nothing Set l_FSO = Nothing End Function |
Thread Tools | Search this Thread |
Display Modes | |
|
|
![]() |
||||
Thread | Forum | |||
programming issue when using Excel automation | Excel Programming | |||
Excel date fields to MS SQL Sever via OLE | Excel Programming | |||
Excel Automation : numbers Copy/Paste issue from VB6 | Excel Programming | |||
Excel Automation Issue | Excel Programming |