Exporting recordset into Excel and opening Excel

Exporting recordset into Excel and opening Excel

Post by Gerry Viato » Wed, 01 Aug 2001 23:49:52



Hi all,

Works fine with 2000 / 2002, having problems with 97.  Doesn't bring in all
the records in the recordset
when using Excel 97.  Sorry for the long post.

Any suggestions?

Thanks
Gerry

Private Sub CmdExportExcel_Click()

 On Error GoTo Err_Handler

 Screen.MousePointer = vbHourglass ' Change mouse pointer to hourglass.
    Dim xlApp As Excel.Application
    Dim xlWb As Excel.Workbook
    Dim xlWs As Excel.Worksheet

    Dim recArray As Variant

    Dim fldCount As Integer
    Dim recCount As Long
    Dim iCol As Integer
    Dim iRow As Integer

    ' Create an instance of Excel and add a workbook
    Set xlApp = CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Add
    Set xlWs = xlWb.Worksheets("Sheet1")

    ' Display Excel and give user control of Excel's lifetime
    xlApp.Visible = True
    xlApp.UserControl = True

    ' Copy field names to the first row of the worksheet
    fldCount = Rs.Fields.Count
    For iCol = 1 To fldCount
        xlWs.Cells(1, iCol).Value = Rs.Fields(iCol - 1).Name
        xlWs.Rows(1).Font.Bold = True
        xlWs.Rows(1).Font.Size = 10
        xlWs.Rows(1).Font.Underline = True
    Next

    ' Check version of Excel
    If Val(Mid(xlApp.Version, 1, InStr(1, xlApp.Version, ".") - 1)) > 8 Then
        'EXCEL 2000 or 2002: Use CopyFromRecordset

        ' Copy the recordset to the worksheet, starting in cell A2
        xlWs.Cells(2, 1).CopyFromRecordset Rs
        'Note: CopyFromRecordset will fail if the recordset
        'contains an OLE object field or array data such
        'as hierarchical recordsets

    Else

    MsgBox "This Option only works with EXCEL 2000 or 2002." , vbExclamation

        'EXCEL 97 or earlier: Use GetRows then copy array to Excel

        ' Copy recordset to an array
        recArray = Rs.GetRows
        'Note: GetRows returns a 0-based array where the first
        'dimension contains fields and the second dimension
        'contains records. We will transpose this array so that
        'the first dimension contains records, allowing the
        'data to appears properly when copied to Excel

        ' Determine number of records

        recCount = UBound(recArray, 2) + 1 '+ 1 since 0-based array

        ' Check the array for contents that are not valid when
        ' copying the array to an Excel worksheet
        For iCol = 0 To fldCount - 1
            For iRow = 0 To recCount - 1
                ' Take care of Date fields
                If IsDate(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = Format(recArray(iCol, iRow))
                ' Take care of OLE object fields or array fields
                ElseIf IsArray(recArray(iCol, iRow)) Then
                    recArray(iCol, iRow) = "Array Field"
                End If
            Next iRow 'next record
        Next iCol 'next field

        ' Transpose and Copy the array to the worksheet,
        ' starting in cell A2
        xlWs.Cells(2, 1).Resize(recCount, fldCount).Value = _
            TransposeDim(recArray)
    End If

    ' Auto-fit the column widths and row heights
    xlApp.Selection.CurrentRegion.Columns.AutoFit
    xlApp.Selection.CurrentRegion.Rows.AutoFit

     xlWs.Rows(1).RowHeight = 25

    ' Close ADO objects
    Rs.Close
    conn.Close
    Set Rs = Nothing
    Set conn = Nothing

    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
    FrmSearch.Height = 4365
        With Screen
          Me.Move (.Width - Width) \ 2, (.Height - Height) \ 2
        End With
   Screen.MousePointer = vbDefault ' Return mouse pointer to normal.

   Exit Sub
Err_Handler:
   If Err.Number = -2147417851 Then
      Resume Next
   End If
      Screen.MousePointer = vbDefault ' Return mouse pointer to normal.
      MsgBox Err.Description, vbCritical, "Error: " & Err.Number
      WriteLog (Err.Number & vbTab & Err.Description & vbTab & "FrmSearch,
CmdExportExcel_Click")

       ' Close ADO objects
    Rs.Close
    conn.Close
    Set Rs = Nothing
    Set conn = Nothing

    ' Release Excel references
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
    FrmSearch.Height = 4365
        With Screen
          Me.Move (.Width - Width) \ 2, (.Height - Height) \ 2
        End With
End Sub

 
 
 

Exporting recordset into Excel and opening Excel

Post by Douglas Laudenschlage » Thu, 02 Aug 2001 03:19:34


Is TransposeDim a function of your own?  If so, could you please post/send
the code?

 
 
 

Exporting recordset into Excel and opening Excel

Post by Gerry Viato » Thu, 02 Aug 2001 03:34:01


Here is the function

thanks for any help

Gerry

Function TransposeDim(V As Variant) As Variant
' Custom Function to Transpose a 0-based array (v)

    Dim X As Long, Y As Long, Xupper As Long, Yupper As Long
    Dim tempArray As Variant

    Xupper = UBound(V, 2)
    Yupper = UBound(V, 1)

    ReDim tempArray(Xupper, Yupper)
    For X = 0 To Xupper
        For Y = 0 To Yupper
            tempArray(X, Y) = V(Y, X)
        Next Y
    Next X

    TransposeDim = tempArray

End Function

Quote:> Is TransposeDim a function of your own?  If so, could you please post/send
> the code?