Create Excel Spreadsheet with VBScript

RottPaws · Apr 9, 2003

I am trying to export data from SQL Server into an Excel spreadsheet. I've got a DTS package that will dump the data into an existing spreadsheet, but I need to create the spreadsheet on the fly.

I've been able to find code that will create a text file and I found that if I name it as .xls, it will work. But I also need to add the column headings so I can dump data into it.

Here's the code I have for creating the file:
'Initialize file system object and file.
Dim fso
Dim a

'Create the text file.
Set fso = CreateObject("Scripting.FileSystemObject&quot

Set a = fso.CreateTextFile("C:\RPTS\gw_fallout.xls&quot

a.Close _________
Rott Paws

...It's not a bug. It's an undocumented feature!!!

arst06d · Apr 10, 2003

dim xl,wb

set xl = createobject("Excel.Application&quot

set wb = xl.workbooks.add
wb.saveas "c:\boo.xls"

wb.close
xl.quit

set xl=nothing
set wb=nothing

you can then reference the newly created workbook

dilettante · Apr 10, 2003

I think arst06d is right. I can't find any way for VBScript to create an Excel workbook besides automating the Excel.Application object.

You can even copy a recordset into a workbook after creating it like this through things such as:

Set xlSheet = wb.Worksheets(1)
xlSheet.Range("A1&quot

.CopyFromRecordset rs

Or you can play around to put in your header information using other objects and methods from Excel.Application.

The big problem is that a server normally doesn't have Excel installed. Even worse, I don't think this works in contexts that don't have a Windows station open (a desktop, visible or hidden). Worse still is that Office automation objects are not meant for concurrent (multiple user context) use in server code which probably would include your DTS package. MS has issued many dire-sounding warnings not to use Office automation objects in ASP pages for example.

Of course that never seems to stop people. If you don't have high scalability requirements and can handle the occasional server blue-screen or thread lockup, this will work.

So what's left? Well MS advises ADO:

Why Use ADO?

The use of ADO to transfer data to or retrieve data from an Excel workbook gives you, the developer, several advantages over Automation to Excel:
[ul][li]Performance. Microsoft Excel is an out-of-process ActiveX server. ADO runs in-process, and saves the overhead of costly out-of-process calls.
[li]Scalability. For Web applications, it is not always desirable to automate Microsoft Excel. ADO presents you with a more scaleable solution to handle data in a workbook.[/ul]
ADO can be used strictly to transfer raw data to a workbook. You cannot use ADO to apply formats or formulas to cells. However, you can transfer data to a workbook that is pre-formatted and the format is maintained. If you require "conditional" formatting after the data is inserted, you can accomplish this formatting with Automation or with a macro in the workbook.

Well cool! But wait a second. Like I said I can't find a way to create a workbook with headings like you need outside of Office automation objects.

One thing you could consider (assuming it met your needs) is to create an empty "template" workbook with just your headings. Then copy it using the FSO, and populate your data via ADO. Maybe this is where you were stuck in the 1st place?

If your workbooks (and worksheets in them) need to be created dynamically I don't have a good answer. If you can copy a standard blank workbook (only headings) and populate it, a simple script like this can do it (WSH example):

Code:

<job id = &quot;CreateXLS&quot;>
  <reference object = &quot;ADODB.Recordset&quot;/>
  <object id = &quot;objFSO&quot; progid = &quot;Scripting.FileSystemObject&quot;/>
  <object id = &quot;objMDBRS&quot; progid = &quot;ADODB.Recordset&quot;/>
  <object id = &quot;objXLSRS&quot; progid = &quot;ADODB.Recordset&quot;/>
  <script language=&quot;VBScript&quot;>
    Option Explicit
    Dim lngField

    'Copy the empty workbook as our new &quot;created&quot; workbook.
    objFSO.CopyFile &quot;WorkBook.xls&quot;, &quot;Created.xls&quot;, True


    'Get the data from the database table
    objMDBRS.Open &quot;Clients&quot;, _
                  &quot;Provider = Microsoft.Jet.OLEDB.4.0;&quot; _
                & &quot;Data Source = Source.mdb;&quot;, _
                  adOpenStatic, adLockReadOnly, adCmdTable

    'Open a recordset to our &quot;table&quot; in the workbook.
    objXLSRS.Open &quot;[Sheet1$]&quot;, _
                  &quot;Provider = Microsoft.Jet.OLEDB.4.0;&quot; _
                & &quot;Data Source = Created.xls;&quot; _
                & &quot;Extended Properties = 'Excel 8.0;Hdr=Yes'&quot;, _
                  adOpenKeyset, adLockOptimistic, adCmdTable

    'Copy the data.
    objMDBRS.MoveFirst
    Do While Not objMDBRS.EOF
      objXLSRS.AddNew
      For lngField = 0 To objMDBRS.Fields.Count - 1
        objXLSRS(lngField).Value = objMDBRS(lngField).Value
      Next
      objXLSRS.Update
      objMDBRS.MoveNext
    Loop

    'Close and finish.  WSH will clean up
    'objects defined using <object> elements.
    objMDBRS.Close
    objXLSRS.Close
    MsgBox &quot;Done!&quot;
  </script>
</job>

But alas, you probably had this part covered already.

Sorry.

dougcranston · Apr 10, 2003

For what it is worth column. Built the following VBScript app that runs on one of my servers to create an Excel spreadsheet based on ADO queries against an Access MDB.

To be sure the following code could be slimmed down, but this is simply a sample.

For what it is worth column.
DougCranston

'~~ScriptName~~. (rpthd.vbs)
'----------------------------------------------------
'~~Author~~. DCranston
'~~Prerequisites~~. VBScript 5.0
'~~Version~~. 1.0
'~~Date Created~~. 2/6/2003
'~~Version_History~~. Initial version
'~~Keywords~~. File exists, FileSystemObject
'~~Description~~. Test if a folder exists and creates one if not.
' Tests for file exists and deletes if exists.
' Creates an Excel spread, extracts data from
' Access MDB via ADO and DSN. Formats the spreadsheet
' saves File.
'-----------------------------------------------------
'~~Usage: rptHD [optional <startdate><enddate>
'~~[No Optional Arguments]: Generates report for last month.
'~~<startdate>: First day of month. Format mm/dd/yyyy
'~~<enddate>: Last day of month under report. Format mm/dd/yyyy
'========= Declarations =================
OPTION EXPLICIT

' Dimension variables
Dim dtFirstDayofLastMonth
Dim dtLastDayofLastMonth
Dim strFile
Dim strFilenm
Dim strfldr
Dim fndt
Dim i
dim strTxt
Dim rs1
Dim rs2
Dim sql
Dim sql1
Dim fldmax
Dim rowmax
Dim rowmax2
Dim iCol
Dim iRow2
Dim iRow
Dim recArray
Dim recCount
Dim result
dim strEndRptDt
dim strStrtRptDt
dim argsvalue
dim argtst

dim numerr
dim abouterr
dim errloc
dim strErrCd
dim errmessage
dim strErrLogFldr
dim strErrLogFn
dim strScriptNm
dim ii
dim strErrMsg
dim strErrTitle

dim dt
dim tdt
dim intDate
dim intDay
dim intMonth
dim intYear
dim oNewFldr
Dim oCn
dim oFilesys
Dim oWshell
Dim oArgs
Dim oXLApp
Dim oXLWb
Dim oXLWs
Dim oMessage
Dim oErrFile
Dim otxtstream
dim ecode

' Create Objects
Set oWShell = WScript.CreateObject("WScript.Shell&quot

Set oArgs = WScript.Arguments

' Assign Values to variables
strScriptNm = "RPTHD"
strFilenm = "rpthd.xls"
strFldr = "c:\cmdfiles\tempfile"
strFile = strFldr & "\" & strFilenm
strErrLogFldr = "c:\cmdfiles\logs"
strErrLogFn = "rcerpthd.log"

call CreateFnm

call CreateRpt

'---------------------------
' Functions and Subroutines
'---------------------------

Public Function CreateFnm()
' Set Error Handler
On Error Resume Next
argsvalue = oArgs.Count

If oArgs.Count = 0 Then
' Has no Args - assumes batch/cron run
' Call create directory routine
Call CreateDir()
' Call clearfile routine
Call ClearFile()
' Calculate start of past month and end of month
dtFirstDayofLastMonth = DateSerial(Year(Date), Month(Date) - 1, 1)
dtLastDayofLastMonth = DateSerial(Year(Date), Month(Date), 0)
set oArgs = nothing

ElseIf oArgs.Count = 2 Then
' Has two Command line arguments - For running other months reports
' Call create directory routine
Call CreateDir

' Test for valid date entered at command line
if isdate(oArgs.Item(0)) then
dtFirstDayofLastMonth = oArgs.Item(0)
Else
Err.Raise vbObjectError + 16 , ,"CustomErr - Invalid date."
strErrCd = "First date entered is not a valid date."
call LogErrors(Err, strErrCd)
wscript.quit(1)
end if

' Test for valid date entered at command line
if isdate(oArgs.Item(1)) then
dtLastDayofLastMonth = oArgs.Item(1)
else
Err.Raise vbObjectError + 16 , ,"CustomErr - Invalid date."
strErrCd = "Second date entered is not a valid date."
call LogErrors(Err, strErrCd)
wscript.quit(1)
end if

' Create filename based on date
tdt = cdate(dtLastDayofLastMonth)
fndt = show_date(tdt)
strFilenm = "rce" & fndt & ".xls"
set oArgs = nothing
Else
' If we got here we have incorrect # of commandline arguments.
set oArgs = nothing
strErrCd = "Incorrect # of commandline arguments."
Err.Raise 450
call LogErrors(Err, strErrCd)
wscript.quit(1)
End If

' Assigns datebased filename to use to name spreadsheet.
CreateFnm=strFilenm
end Function

function show_date(dt)
' Function to convert date to mmyy with 0 padding
' Set Error Handler
On Error Resume Next
' Initialize local variables
intDate = dt
intDay = Day(intDate)
intMonth = Month(intDate)
intYear = Year(intDate)

'Get the day : parse method
if Len(intDay)=1 Then intDay = "0" & intDay

'Get the month : parse method
if Len(intMonth)=1 Then intMonth = "0" & intMonth

'get the year : parse method
if Len(intYear)=4 Then intYear = Right(intYear, 2)

show_date = intMonth & intYear

'Test for Error
If Err.Number <> 0 then
Err.Raise vbObjectError + 17 , ,"CustomErr - Process failed."
strErrCd = "Generated filename based on date process failed."
call LogErrors(Err, strErrCd)
wscript.quit(1)
End if

End function

Public Sub CreateDir()
' Test to see if Folder Exists and if not create it
' Set Error Handler
On Error Resume Next

' Test and create script output folder
Set oFilesys = CreateObject("Scripting.FileSystemObject&quot

If Not oFilesys.FolderExists(strFldr) Then
Set oNewFldr = oFilesys.CreateFolder(strFldr)
Set oNewFldr = Nothing
End If
' Test and create script ERROR LOG folder
If Not oFilesys.FolderExists(strErrLogFldr) Then
Set oNewFldr = oFilesys.CreateFolder(strErrLogFldr)
Set oNewFldr = Nothing
End If
set oFilesys = Nothing

'Test for Error
If Err.Number <> 0 then
Err.Raise vbObjectError + 18 , ,"CustomErr - Create Dir failed."
strErrCd = "Creating Subdirectory process failed."
call LogErrors(Err, strErrCd)
wscript.quit(1)
End if

End Sub

Public Sub ClearFile()
' Test if Old version of file exists delete it
' Set Error Handler
On Error Resume Next

Set oFilesys = CreateObject("Scripting.FileSystemObject&quot

if oFilesys.FileExists(strFile) then
oFilesys.DeleteFile(strFile)
end if
set oFilesys = Nothing

'Test for Error
If Err.Number <> 0 then
strErrCd = "Creating Subdirectory process failed."
call LogErrors(Err, strErrCd)
wscript.quit(1)
End if

End Sub

Sub CreateRpt()
' Connect to the db with a DSN-less connection
' Set Error Handler
On Error Resume Next
' --- Create Instance of Connection Object ---
Set oCn = Wscript.CreateObject("ADODB.Connection&quot

oCn.Open "DSN=rcerpt" 'DC home
' oCn.Open "DSN=rptrqst" ' dc dsktop2000 ofc

' Create a server recordset object
Set rs1 = Wscript.CreateObject("ADODB.Recordset&quot

' Define Query to determine select criteria
sql1 = "SELECT DISTINCT tblStores.txtRegion "
sql1 = sql1 & "FROM tblStores "
sql1 = sql1 & "ORDER BY tblStores.txtRegion;"

' Execute the sql
rs1.Open sql1, oCn, 3, 3

'this opens a recordset with all unique names in Field
If Not rs1.EOF Then
rs1.MoveLast
rs1.movefirst
rowmax2 = rs1.RecordCount
End If

' Create an instance of Excel and add a workbook
Set oXLApp = CreateObject("Excel.Application&quot

'this required to determine recordcount
oXLApp.SheetsInNewWorkbook = rs1.RecordCount

'create a workbook with required sheets number
Set oXLWb = oXLApp.Workbooks.Add

'cycle thru sheets
For i = 1 To rowmax2
Set oXLWs = oXLWb.Worksheets(i)
oXLWs.Name = rs1.Fields(0).Value

' Create recordset obj
Set rs2 = Wscript.CreateObject("ADODB.Recordset&quot

' Define main query
sql = "SELECT DISTINCTROW tblStores.txtStoreNo, "
sql = sql & "tblStores.txtStoreRCECd, tblStores.txtRegion, "
sql = sql & "tblStores.txtStoreName, "
sql = sql & "tblStores.txtState, "
sql = sql & "tblRequests.dtRqstSubmitted, "
sql = sql & "tblRequests.dtRptDate, tblRequests.txtRptType, "
sql = sql & "LCase([txtRequestor]), "
sql = sql & "tblRequests.txtBatchNo, "
sql = sql & "LCase([txtRqstReason])"
sql = sql & "FROM tblRequests INNER JOIN tblStores "
sql = sql & "ON tblRequests.txtStoreRCECd = tblStores.txtStoreRCECd "
sql = sql & "WHERE (((tblRequests.dtRqstSubmitted) Between #" & dtFirstDayofLastMonth & "# And #" & dtLastDayofLastMonth & "#)) "
sql = sql & "AND tblStores.txtRegion = '" & rs1.Fields(0).Value & "' "
sql = sql & "ORDER BY tblStores.txtRegion, "
sql = sql & "tblStores.txtStoreNo, "
sql = sql & "tblRequests.dtRqstSubmitted;"

' Execute the sql
rs2.Open sql, oCn, 3, 3

' Call function to process request
Call TXLOut(sql, rs1.Fields(0).Value)
' Clean up Recordset
rs2.Close
Set rs2 = Nothing
' Next Record
rs1.movenext
Next 'i

' Close and set the recordset to nothing
rs1.Close
Set rs1 = Nothing

' Close and set the connection to nothing
oCn.Close
Set oCn = Nothing

' Save the spreadsheet as
oXLWb.SaveAs (strFldr & "\" & createFnm)
Set oXLWs = Nothing
oXLWb.Close False '/False to ignore changes '/ True to save changes
Set oXLWb = Nothing
oXLApp.Quit
Set oXLApp = Nothing
Set oFilesys = Nothing

' Send completed spreadsheet via email to assigned users
' Call sndfilemsg(dtFirstDayofLastMonth, dtLastDayofLastMonth, argsvalue)

'Test for Error
If Err.Number <> 0 then
strErrCd = "Creating Report process failed."
call LogErrors(Err, strErrCd)
wscript.quit(1)
End if

End Sub

Public Function TXLOut(sql,sheet)
'Notice, that you need References to ADO
' Set Error Handler
On Error Resume Next

' Block display Excel and user control of Excel's lifetime
' FOR TESTING SET BOTH TO TRUE set to False to run scripted/crond
oXLApp.Visible = FALSE
oXLApp.UserControl = FALSE

' Test and address empty recordset
if rs2.BOF and rs2.EOF then
' Add Indication of records
oXLWs.Cells(2 , 9).Value = "No Report Requests For This Time Period"
With oXLWs.Range("I2&quot

.Interior.Color = RGB(196,196,196)
End With
Else

' Determine the array we are dealing with
If Not rs2.BOF And Not rs2.EOF Then
rs2.MoveFirst()
rs2.MoveLast()
rowmax = rs2.RecordCount + 1
fldmax = rs2.Fields.Count
End If

' Move to first record in recordset
rs2.movefirst

' Set counter for positioning data posting
iRow2 = 2

' Start a for/next loop that will end with the last record
For iRow = iRow2 To rowmax
For iCol = 1 To fldmax
If (rs2.Fields.Item(iCol - 1) = "&quot

Then
oXLWs.Cells(iRow, iCol).Value = ""
Else
oXLWs.Cells(iRow, iCol).Value = rs2.Fields(iCol - 1).Value
End If
Next
iRow2 = iRow2 + 1
' Move to the next record
rs2.movenext
Next
' Add Indication of records
oXLWs.Cells(rowmax + 1, 9).Value = "Total Requests"
oXLWs.Cells(rowmax + 1, 11).Value = rowmax - 1
' Set shading for column titles
With oXLWs.Range("A" & rowmax +1 &":" & PickCol(fldmax) & rowmax +1)
.Interior.Color = RGB(196,196,196)
End With
End If

' Set field names to the first row of the worksheet
oXLWs.Cells(1, 1).Value = "Store#"
oXLWs.Cells(1, 2).Value = "Cd"
oXLWs.Cells(1, 3).Value = "Region"
oXLWs.Cells(1, 4).Value = "Store Name"
oXLWs.Cells(1, 5).Value = "State"
oXLWs.Cells(1, 6).Value = "Dt Sbmtd"
oXLWs.Cells(1, 7).Value = "Rprt Dt"
oXLWs.Cells(1, 8).Value = "Rpt Type"
oXLWs.Cells(1, 9).Value = "Requestor"
oXLWs.Cells(1, 10).Value = "Batch #"
oXLWs.Cells(1, 11).Value = "Reason"

' Set Column Widths
oXLWs.Columns(1).ColumnWidth = 5.57
oXLWs.Columns(2).ColumnWidth = 5.57
oXLWs.Columns(3).ColumnWidth = 4
oXLWs.Columns(4).ColumnWidth = 19.75
oXLWs.Columns(5).ColumnWidth = 4
oXLWs.Columns(6).ColumnWidth = 9.3
oXLWs.Columns(7).ColumnWidth = 9.3
oXLWs.Columns(8).ColumnWidth = 8.3
oXLWs.Columns(9).ColumnWidth = 16.86
oXLWs.Columns(10).ColumnWidth = 5.57
oXLWs.Columns(11).ColumnWidth = 25

' Set first row as column titles over mult pages
With oXLWs.PageSetup
.PrintTitleRows = "$1:$1"
End With
oXLWs.PageSetup.PrintArea = ""

' Set Page header and footers, page margins, layout
oXLWs.PageSetup.PrintArea = ""
With oXLWs.PageSetup
.LeftHeader = ""
.CenterHeader = "Reprint Requests by Region/Store#/Date Request Submitted for Period: " & dtFirstDayofLastMonth & "-" & dtLastDayofLastMonth
.RightHeader = ""
.LeftFooter = "&F"
.CenterFooter = "Page - &P"
.RightFooter = "&D &T"
.LeftMargin = oXLApp.InchesToPoints(0.5)
.RightMargin = oXLApp.InchesToPoints(0.5)
.TopMargin = oXLApp.InchesToPoints(0.8)
.BottomMargin = oXLApp.InchesToPoints(0.8)
.HeaderMargin = oXLApp.InchesToPoints(0.5)
.FooterMargin = oXLApp.InchesToPoints(0.5)
.PrintHeadings = False
.PrintGridlines = False
.PrintComments = -4142
.Orientation = 2 ' landscape
.PrintQuality = 600
.CenterHorizontally = False
.CenterVertically = False
.Draft = False
.PaperSize = 1 ' xlPaperLetter
.FirstPageNumber = 1 ' xlAutomatic
.Order = 1 ' xlDownThenOver
.BlackAndWhite = False
.Zoom = 100
End With

' Set formatting for entire sheet
' Addition of a + 1 is to include formatting for the report total line
' oXLWs.Range("A1:" & PickCol(fldmax) & rowmax + 1).Select
oXLWs.Range("A1:" & PickCol(fldmax) & rowmax + 1).Font.Name = "Times New Roman"
oXLWs.Range("A1:" & PickCol(fldmax) & rowmax + 1).Font.Size = 8
oXLWs.Range("A1:" & PickCol(fldmax) & rowmax + 1).Font.Bold = True
oXLWs.Range("A1:" & PickCol(fldmax) & rowmax + 1).WrapText = True

' Set shading for column titles
With oXLWs.Range("A1:" & PickCol(fldmax) & "1&quot

.Interior.Color = RGB(196,196,196)
End With

' Set lines around cells
With oXLWs.Range("A1:" & PickCol(fldmax) & rowmax)
with .Borders(7)
.LineStyle = 1
.Weight = 2
.Color = RGB(0,0,0)
end with
with .Borders(8)
.LineStyle = 1
.Weight = 2
.Color = RGB(0,0,0)
end with
with .Borders(9)
.LineStyle = 1
.Weight = 2
.Color = RGB(0,0,0)
end with
with .Borders(10)
.LineStyle = 1
.Weight = 2
.Color = RGB(0,0,0)
end with
with .Borders(11)
.LineStyle = 1
.Weight = 2
.Color = RGB(0,0,0)
end with
with .Borders(12)
.LineStyle = 1
.Weight = 2
.Color = RGB(0,0,0)
end with
End With

'Test for Error
If Err.Number <> 0 then
strErrCd = "Creating Report process failed."
call LogErrors(Err, strErrCd)
wscript.quit(1)
End if

End Function

Function PickCol(fldmax)
' Translates cell column # to Alpha Char for cell ref
Select Case fldmax
Case 1
result = "A"
Case 2
result = "B"
Case 3
result = "C"
Case 4
result = "D"
Case 5
result = "E"
Case 6
result = "F"
Case 7
result = "G"
Case 8
result = "H"
Case 9
result = "I"
Case 10
result = "J"
Case 11
result = "K"
Case 12
result = "L"
Case 13
result = "M"
Case 14
result = "N"
Case 15
result = "O"
Case 16
result = "P"
Case 17
result = "Q"
Case 18
result = "R"
Case 19
result = "S"
End Select
PickCol = result
End Function

Function LogErrors(objErr,strErrCd)
' Function writes information to an Error log file and
' generates an email warning to server administrators
'
errloc = strErrCd
numerr = Err.Number
abouterr = Err.Description

strErrTitle = "Error in: " & strScriptNm & " Error#: " & numerr & " Type: " & abouterr
If numerr <> 0 Then

Set oErrFile = CreateObject("Scripting.FileSystemObject&quot

Set otxtstream = oErrFile.OpenTextFile(strErrLogFldr & "\" & strErrLogFn, 8, TRUE)

otxtstream.writeline("START Error log Page: " & " Date: " & Now() & " Err.Number: " & Err.Number)

' Determine whether a VBS error has occurred and log it
If Err.Number <> 0 Then
' Report properties of VBScript Err object and write to logfile
otxtstream.writeline("VBScript Err Object:&quot

otxtstream.writeline("Err Occurred at: " & strErrCd)
otxtstream.writeline("Number: " & Err.Number)
otxtstream.writeline("Description: " & Err.Description)
otxtstream.writeline("Source: " & Err.Source)
otxtstream.writeline("HelpFile: " & Err.HelpFile)
otxtstream.writeline("HelpContext: " & Err.HelpContext)
' Report propertiesof VBScript Err object for emailing report
strErrTitle = "Error in: "& strScriptNm & " Date: " & Now() & " Err.Number: " & Err.Number
strErrMsg = "VBScript Err Object:" & vbcrlf
strErrMsg = strErrMsg & "Err Occurred at: " & strErrCd & vbcrlf
strErrMsg = strErrMsg & "Number: " & Err.Number & vbcrlf
strErrMsg = strErrMsg & "Description: " & Err.Description & vbcrlf
strErrMsg = strErrMsg & "Source: " & Err.Source & vbcrlf
strErrMsg = strErrMsg & "HelpFile: " & Err.HelpFile & vbcrlf
strErrMsg = strErrMsg & "HelpContext: " & Err.HelpContext & vbcrlf & vbcrlf

End if
End if

' Determine whether an ADO Error has occurred and log it
If IsObject(oCn) Then
If oCn.Errors.Count > 0 Then
For ii = 0 To oCn.Errors.Count - 1
' Report properties of ADO Error object.
otxtstream.writeline("ADO Error Object:&quot

otxtstream.writeline("Number: " & oCn.Errors(ii).Number)
otxtstream.writeline("Description: " & oCn.Errors(ii).Description)
otxtstream.writeline("Source: " & oCn.Errors(ii).Source)
otxtstream.writeline("HelpFile: " & oCn.Errors(ii).HelpFile)
otxtstream.writeline("HelpContext: " & oCn.Errors(ii).HelpContext)
otxtstream.writeline("SQL State: " & oCn.Errors(ii).SQLState)
otxtstream.writeline("NativeError: " & oCn.Errors(ii).NativeError)
' End the range of the loop through all Error objects.
strErrMsg = strErrMsg & "ADO Error Object:" & vbcrlf
strErrMsg = strErrMsg & "Number: " & oCn.Errors(ii).Number & vbcrlf
strErrMsg = strErrMsg & "Description: " & oCn.Errors(ii).Description & vbcrlf
strErrMsg = strErrMsg & "Source: " & oCn.Errors(ii).Source & vbcrlf
strErrMsg = strErrMsg & "HelpFile: " & oCn.Errors(ii).HelpFile & vbcrlf
strErrMsg = strErrMsg & "HelpContext: " & oCn.Errors(ii).HelpContext & vbcrlf
strErrMsg = strErrMsg & "SQL State: " & oCn.Errors(ii).SQLState & vbcrlf
strErrMsg = strErrMsg & "NativeError: " & oCn.Errors(ii).NativeError & vbcrlf & vbcrlf

Next
End If
Set oCn = Nothing
End If
otxtstream.writeline("END Error log Page: " & " Date: " & Now() & vbcrlf & vbcrlf)

' Send Error Message to System Administrators of Problem Encountered
' If used on WIN2 Server/WS remove the double ''
' and then comment out the CDONTS

' Sending a text email using a CDOSYS not CDONTS

Set oMessage = CreateObject("CDO.Message&quot

oMessage.From = "fromuser@from.com"
oMessage.To = "touser@to.com"
oMessage.Subject = strErrTitle & " Scheduled Task"
oMessage.Textbody = strErrMsg
oMessage.Configuration.Fields.Item _
("

http://schemas.microsoft.com/cdo/configuration/sendusing")

= 2
oMessage.Configuration.Fields.Item _
("

http://schemas.microsoft.com/cdo/configuration/smtpserver")

= _
"yoursmtpmailserver url"
oMessage.Configuration.Fields.Item _
("

http://schemas.microsoft.com/cdo/configuration/smtpserverport")

= 25
oMessage.Configuration.Fields.Update
oMessage.Send
Set oMessage=Nothing

' CDONTS email for NT
' If using CDONTS remove double single quotes and comment out CDOSYS lines

'' set oMessage = CreateObject("CDONTS.NewMail&quot

'' oMessage.Subject = strErrTitle & " Scheduled Task"
'' oMessage.From = "fromuser@from.com"
'' oMessage.To = "touser@to.com"
'' oMessage.Cc = "ccuser@cc.com"
'' oMessage.Body = strErrMsg & VbCrLf
'' oMessage.Send
'' set oMessage=nothing

Wscript.Quit(1)
End Function

Public Function sndfilemsg(dtFirstDayofLastMonth, dtLastDayofLastMonth, argsvalue)
' Emails the report to the assigned personnel
' Set Error Handler
On Error Resume Next

strStrtRptDt = dtFirstDayofLastMonth
strEndRptDt = dtLastDayofLastMonth
argtst = cint(argsvalue)

If argtst = 0 then
' Send Error Message to System Administrators of Problem Encountered
' If used on WIN2 Server/WS remove the double ''
' and then comment out the CDONTS

' Sending a text email using a CDOSYS not CDONTS

Set oMessage = CreateObject("CDO.Message&quot

oMessage.From = "fromuser@from.com"
oMessage.To = "touser@to.com"
oMessage.Subject = "Report Requests for: " & strStrtRptDt & "-" & strEndRptDt
oMessage.AddAttachment "c:\cmdfiles\tempfile\rcerpthd.xls"
oMessage.TextBody = "The attached Excel file contains last months Reprint Requests Summary." & VbCrLf
oMessage.Configuration.Fields.Item _
("

http://schemas.microsoft.com/cdo/configuration/sendusing")

= 2
oMessage.Configuration.Fields.Item _
("

http://schemas.microsoft.com/cdo/configuration/smtpserver")

= _
"yoursmtpmailaddress"
oMessage.Configuration.Fields.Item _
("

http://schemas.microsoft.com/cdo/configuration/smtpserverport")

= 25
oMessage.Configuration.Fields.Update
oMessage.Send
Set oMessage=Nothing

' CDONTS email for NT
' If using CDONTS remove double single quotes and comment out CDOSYS lines

'wscript.echo strStrtRptDt
'wscript.echo strEndRptDt

'' set oMessage = CreateObject("CDONTS.NewMail&quot

'' oMessage.Subject = "Report Requests for: " & strStrtRptDt & "-" & strEndRptDt
'' oMessage.From = "fromuser@verizon.com"
'' oMessage.To = "touser@to.com"
'' oMessage.Cc = "ccuser@ccuser.com"
'' oMessage.AttachFile("c:\cmdfiles\tempfile\rcerpthd.xls&quot

'' oMessage.Body = "The attached Excel file contains last months Reprint Requests Summary." & VbCrLf
'' oMessage.Send
'' set oMessage=nothing

End if

'Test for Error
If Err.Number <> 0 then
strErrCd = "Creating Email distribution process failed."
call LogErrors(Err, strErrCd)
wscript.quit(1)
End if

End Function

dilettante · Apr 10, 2003

Wow, now there's a script!

Still, too bad Jet can't create a workbook and add tables via ADOX the way you can an MDB (Access) database.

dougcranston · Apr 11, 2003

Via Jet would be the ultimate.

I am sure a real programmer would be able to slim down and make the sample script "sing".. Just my best effort. Lots of room for improvement and experience.

DougCranston

RottPaws · Apr 11, 2003

Thanks for the scripts.

dilettante,
You were correct that I was stuck at creating a template. I need to dump the file to the local drive on the server. It seems strange, but I don't have direct access to create/copy a file to the server's local drive, but I could create a file and work with it through a script. It seems silly, but network permissions go that way sometimes .....

I'll try to work through these scripts and create the Excel file. In the meantime, I got it to work by dumping it to a csv file instead. _________
Rott Paws

...It's not a bug. It's an undocumented feature!!!

CrystalVis · Apr 11, 2003

Rott Paws,
You should be able to handle this with DTS package alone.
1. create an empty spreadsheet on the server: c:\shared\test.xls (name the sheet within the test.xls so that you can reference it later letter call it DATA)

2. create an excel connection. the datasource should be Microsoft Excel 97-2000. The file name should be the full path and file name that you create in step 1 (c:\shared\test.xls)

3. use the Transform Data Task to pump the data into the excel connection. Of course, you configure the data pump such as source...when you click on the destination, select create new table and name your table the same name that you named the sheet in the test.xls (DATA). This should automatically create the data in the excel format sheet. If you run it everyday, you have to drop the DATA table and re-create it in order to get only new data in the sheet. Otherwise, the data will append onto what you already have in the sheet. Hope this is what you're looking for.

RottPaws · Apr 14, 2003

The problem I'm running into is in creating the file. When I am in design mode for the DTS package or when I execute it from Enterprise Manager, it works on my local workstation. So C:\RPTS\data.xls, for instance, is a file on my machine. I can create an empty file named data.xls on my local drive and the DTS package does exactly what I want it to do.

But when the DTS package is run automatically from a job, it uses the local drives of the server. I don't have direct access to create files on the server's hard drive. That's why I need the DTS package to create the file itself.

I'll keep playing around with it as time permits. I think the code above should help. In the mean-time, I've got it working using a txt (csv) destination document and I've been assigned some other priority stuff . . .

Thanks again for your help.

_________
Rott Paws

...It's not a bug. It's an undocumented feature!!!

Tek-Tips is the largest IT community on the Internet today!

Members share and learn making Tek-Tips Forums the best source of peer-reviewed technical information on the Internet!

Create Excel Spreadsheet with VBScript

RottPaws

Programmer

arst06d

Programmer

dilettante

MIS

dougcranston

Technical User

dilettante

MIS

dougcranston

Technical User

RottPaws

Programmer

CrystalVis

Technical User

RottPaws

Programmer

Similar threads

Part and Inventory Search

Sponsor