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
 *