Category Archives: VB

This simple piece of code to export one recordset to excel

 
' ------------------------------------------------------------------------------------
' \\ -- function to export the ADO recordset to  Excel
' ------------------------------------------------------------------------------------
Private Function Exportar_ADO_Excel(rec As ADODB.Recordset) As Boolean
      
    On Error GoTo errSub
      
    'Dim cn          As New ADODB.Connection
    'Dim rec         As New ADODB.Recordset
    Dim Excel       As Object
    Dim Libro       As Object
    Dim Hoja        As Object
    Dim arrData     As Variant
    Dim iRec        As Long
    Dim iCol        As Integer
    Dim iRow        As Integer
      
    Me.Enabled = False
      
     
    ' -- Create Excel objects
    Set Excel = CreateObject("Excel.Application")
    Set Libro = Excel.Workbooks.Add
      
    ' -- open sheet
    Set Hoja = Libro.Worksheets(1)
      
    Excel.Visible = True: Excel.UserControl = True
    ' -- send headers
    iCol = rec.Fields.Count
    For iCol = 1 To rec.Fields.Count
        Hoja.Cells(1, iCol).Value = rec.Fields(iCol - 1).Name
    Next
      
    If Val(Mid(Excel.Version, 1, InStr(1, Excel.Version, ".") - 1)) > 8 Then
        Hoja.Cells(2, 1).CopyFromRecordset rec
    Else
  
        arrData = rec.GetRows
  
        iRec = UBound(arrData, 2) + 1
          
        For iCol = 0 To rec.Fields.Count - 1
            For iRow = 0 To iRec - 1
  
                If IsDate(arrData(iCol, iRow)) Then
                    arrData(iCol, iRow) = Format(arrData(iCol, iRow))
  
                ElseIf IsArray(arrData(iCol, iRow)) Then
                    arrData(iCol, iRow) = "Array Field"
                End If
            Next iRow
        Next iCol
              
        ' -- send all records to  Excel
        Hoja.Cells(2, 1).Resize(iRec, rec.Fields.Count).Value = GetData(arrData)
    End If
  
    Excel.Selection.CurrentRegion.Columns.AutoFit
    Excel.Selection.CurrentRegion.Rows.AutoFit
  
   
    ' -- delete references
    Set Hoja = Nothing
    Set Libro = Nothing
    ' not quit excel
    'Excel.Quit
    'Set Excel = Nothing
      
    Exportar_ADO_Excel = True
    'Me.Enabled = True
    Exit Function
errSub:
    MsgBox Err.Description, vbCritical, "Error"
    Exportar_ADO_Excel = False
    Me.Enabled = True
End Function