Excel_Conversation, tips, CopyFromRecordSet
---
Hi (what is your name?),
If you are not comfortable with VBA, email me and request the VBA
chapters I send out free
here is some "shell" code I use when I am going to write a program with
Excel automation...
'~~~~~~~~~~~~~~~~~~~~~~~~~~
Function Excel_Conversation()
On Error GoTo Proc_Err
Dim xlApp As Excel.Application, _
booLeaveOpen As Boolean
'if Excel is already open, use that instance
booLeaveOpen = True
'attempting to use something that is not available
'will generate an error
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
On Error GoTo Proc_Err
'If xlApp is defined, then we
'already have a conversation
If TypeName(xlApp) = "Nothing" Then
booLeaveOpen = False
'Excel was not open -- create a new instance
Set xlApp = CreateObject("Excel.Application")
End If
'Do whatever you want
Proc_Exit:
On Error Resume Next
If TypeName(xlApp) <> "Nothing" Then
xlApp.ActiveWorkbook.Close False
If Not booLeaveOpen Then xlApp.Quit
Set xlApp = Nothing
End If
Exit Function
Proc_Err:
MsgBox Err.Description _
, , "ERROR " & Err.Number & " Excel_Conversation"
'comment next line after debugged
Stop: Resume
Resume Proc_Exit
End Function
'~~~~~~~~~~~~~~~~~~~~~~~~
I often use a template to make new workbooks with one sheet ("master"),
that I make copies of, fill and rename. I have found the the formatting
doesn't always stick in Excel, so this syntax has been very handy for
formatting a range...
xlApp.Range(xlSht.Cells(8, 5), xlSht.Cells(mRow + 1, 10)).NumberFormat =
"#,##0"
'~~~~~~~~~~~~~~~~~~~~~~~~
and for putting formulas into Excel instead of calculation results...
xlSht.Cells(mRow, 7).Formula = "=IF(E" & mRow & "=0,0,F" & mRow & "/E" &
mRow & ")"
pSht.Cells(pRow2, 5).Formula = "=SUM(E" & pRow1 & ":E" & pRow2 - 1 & ")"
"p" is my passed parameter notation -- to modularize the code, I often
send a recordset, an Excel object reference, possibly row numbers,
etc... to another routine to do the writing to Excel. That way, it is
easier to add a loop too
'~~~~~~~~~~~~~~~~~~~~~~~~
here's another handy tip...
to launch Excel code from Access
'this is the workbook with the code if it is somewhere else
xlApp.Workbooks.Open mPath & "PROGRAMS.XLS"
'this is the workbook to run code on, or just to open
xlApp.Workbooks.Open mExcelFile
'run Sub in Programs Workbook if applicable
xlApp.Run "PROGRAMS.XLS!ModuleName.SubName"
'~~~~~~~~~~~~~~~~~~~~~~~~
to make a new workbook based on a template...
xlApp.Workbooks.Add _
Template:= _
CurrentProject.Path _
& "\Templates\Filename.xlt"
~~~
for copying large amounts of data such as returns from a table or query,
an efficient way is to use CopyFromRecordSet. Here is some code that
you can use as an example -- the base code was provided by NateO, a real
ADO genius:
'~~~~~~~~~~~~~~~~~~~
Sub MakePullLists(pPath As String, pQname As String)
On Error GoTo Proc_Err
'Declare your ADO Recordset
Dim rs As ADODB.Recordset
'Excel Objects
' Dim xlApp As Excel.Application
' Dim xlWb As Excel.Workbook
Dim xlApp As Object
Dim xlWb As Object
'Field Names - Stack into Array
Dim fldArr() As String
'Need some loop counters
Dim j As Long _
, iQ As Long _
, i As Long
Dim mFilename As String
mFilename = pPath & pQname
i = 1
'OLE - Create xl Objects
Set xlApp = CreateObject("Excel.application")
' Set xlApp = New Excel.Application
'Add a new Workbook, with one Worksheet, to our Excel Application
Set xlWb = xlApp.Workbooks.Add(1)
'this is commented out because to show you can loop if you want
'For i = LBound(sqlArr) To UBound(sqlArr)
'New ADO Recordset
Set rs = New ADODB.Recordset
'Open the Recordset, Passing the Sql from our Array
rs.Open CurrentDb.QueryDefs(pQname).SQL, CodeProject.Connection, _
adOpenStatic, adLockReadOnly
With rs
'Stack a String Array with the Field Names
ReDim fldArr(0 To .Fields.Count - 1)
For j = LBound(fldArr) To UBound(fldArr)
Let fldArr(j) = .Fields(j).Name
Next j
'Time to Pass some Data to Excel!
With xlWb.Worksheets
'Add a Worksheet if we're at 2nd Recordset or Greater
If i > 1 Then .Add After:=.Item(i - 1)
'Refer to the Worksheet by Item Number
'in the Collection of Worksheets (1-based)
With .Item(1)
'Pass our dynamic Field String Array to A1,
'stretched to the Right for number of Elements
Let .Range("a1").Resize(, UBound(fldArr) + 1).Value = fldArr
'Copy our Current Recordset to A2
.Range("a2").CopyFromRecordset rs
'Rename Individual Worksheet
.Name = "WorksheetName"
'however many columns of data you have, if desired
.Columns("A:G").EntireColumn.AutoFit
End With
End With
End With
'Moving on, no need to close or terminate our RS, yet,
' we're going to recycle in the Loop
'end of optional loop
'Next
'Make Excel visible - (Otherwise Save and Close)
With xlApp
.Goto xlWb.Worksheets(1).Range("A1")
'commented but can be activated if desired
'xlSht.Cells(1, 1).Activate
'.Visible = True
End With
Save_Workbook:
'delete file if it already exists
If Dir(mFilename) <> "" Then
On Error Resume Next
Kill mFilename
DoEvents
On Error GoTo Proc_Err
End If
'commented because there was not code to disable in this case
'if you are writing to a template with code, you may want
'to disable events in the beginning
'xlApp.EnableEvents True
xlApp.ActiveWorkbook.SaveAs mFilename
xlApp.ActiveWorkbook.Close False
Proc_Exit:
On Error Resume Next
'Terminate our Excel Object Variables
Set xlWb = Nothing
If TypeName(xlApp) <> "Nothing" Then
xlApp.Quit
Set xlApp = Nothing
End If
'Now close and terminate the ADO Recordset, we're all done!!
rs.Close: Set rs = Nothing
Exit Sub
Proc_Err:
MsgBox Err.Description, , "ERROR " & Err.Number & " MakePullLists"
'press F8 to step through code and debug
'remove next line after debugged
Stop: Resume
Resume Proc_Exit
End Sub
'~~~~~~~~~~~~~~~~~~~~~
the reason for this:
' Dim xlApp As Excel.Application
' Dim xlWb As Excel.Workbook
Dim xlApp As Object
Dim xlWb As Object
is because I often use early binding (as Excel.xxxx) for developing and
late binding (as Object) for distribution
Warm Regards,
Crystal
*
have an awesome day
*
MVP Access
Remote Programming and Training
strive4peace2006 at yahoo.com
*
