Exportar recordset a excel - No reconoce rs.Filter

[lucius]

Tenia pensado utilizar la siguinte funcion pero me he dado cuenta que cuando tengo un rs.filter="campo='50'" pues simplemente lo ignora y me exportar todo el recordset completo.

Código: (VB) [Seleccionar]

Public Function Export_sExcel(rec As Recordset) As Boolean
    On Error GoTo errSub
    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

    Screen.MousePointer = 11
    ' -- Crear los objetos para utilizar el Excel
    Set Excel = CreateObject("Excel.Application")
    Set Libro = Excel.Workbooks.Add
       
    ' -- Hacer referencia a la hoja
    Set Hoja = Libro.Worksheets(1)
    Excel.Visible = True: Excel.UserControl = True
   
    Hoja.Cells(1, 1).Value = "Titulo"
   
    iCol = rec.Fields.Count
    For iCol = 1 To rec.Fields.Count
        Hoja.Cells(3, iCol).Value = rec.Fields(iCol - 1).Name
    Next

    If Val(Mid(Excel.Version, 1, InStr(1, Excel.Version, ".") - 1)) > 8 Then
        Hoja.Cells(4, 1).CopyFromRecordset rec
    Else
        'arrData = rec.GetRows
        'iRec = UBound(arrData, 2) + 1 'ubound devuelve el subindice mas alto
        'For iCol = 0 To rec.Fields.Count - 1 'recordset de 0 a 3 osea 4 campos
            '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
        ' -- Traspasa los datos a la hoja de 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
   
    'Hoja.Name = ""
    'Libro.saveAs App.Path & "\libro"
    'Libro.Close

    Set Hoja = Nothing
    Set Libro = Nothing
    Set Excel = Nothing
   
    Export_sExcel = True
    Screen.MousePointer = 0
    Exit Function
errSub:
    MsgBox Err.Description, vbCritical, "Error"
    Export_sExcel = False
    Screen.MousePointer = 0
End Function
 
Private Function GetData(vValue As Variant) As Variant
    Dim X As Long, Y As Long, xMax As Long, yMax As Long, T As Variant
       
    xMax = UBound(vValue, 2): yMax = UBound(vValue, 1)
       
    ReDim T(xMax, yMax)
    For X = 0 To xMax
        For Y = 0 To yMax
            T(X, Y) = vValue(Y, X)
        Next Y
    Next X
       
    GetData = T
End Function


[raul338]

Puede ser por la linea:
Hoja.Cells(4, 1).CopyFromRecordset rec

Prueba comentando el if y ejecutando solo la parte del else que esta comentada. Parece más bien que es el mismo excel que lo hace eso

[Waldo]

La linea :
 Hoja.Cells(4, 1).CopyFromRecordset rec

Es la que copia el recordset a la hoja, creo que debe ser un bug de la funcion CopyFromRecordset .

No te va a quedar otra que abrir el recordset y recorrerlo linea x linea.

[lucius]

Noooo
Pucha si alguien tiene algo armado seria bueno igual como raul quiza mandando directamente la parte comentada la cual es para versiones antiguas de excel aunque lo dudo, saludos

[AxioUK]

Amigo lucius:
 Prueba a usar este, que adapté en su momento de una función que servía para exportar un FlexGrid a Excel que encontré en un foro (ya no recuerdo donde, si te fijas es de 1999  jeje):
funciona para mi, aunque nunca usé un .Filter en un recordset ...

Pruebalo y nos cuentas

Este Code en una Clase xlsV2:

Código: (VB) [Seleccionar]

Option Explicit
' Class om versie 2 Excel file uit te schrijven
' ondersteund: strings, integers, doubles
' 1 sheet per excel file
' gebaseerd op een stuk code gevonden op het internet
' Arnout: 12 oktober 1999

'Beginning Of File record
Private Type BOF
  opcode As Integer
  Length As Integer
  Version As Integer
  ftype As Integer
End Type

'End Of File record
Private Type EOF
  opcode As Integer
  Length As Integer
End Type

'Integer record
Private Type tInteger
  opcode As Integer
  Length As Integer
  Row As Integer
  col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  Value As Integer
End Type

'Number = double record
Private Type tNumber
  opcode As Integer
  Length As Integer
  Row As Integer
  col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  Value As Double
End Type

'Label (Text) record
Private Type tLabel
  opcode As Integer
  Length As Integer
  Row As Integer
  col As Integer
  rgbAttr1 As Byte
  rgbAttr2 As Byte
  rgbAttr3 As Byte
  strLength As Byte
End Type

Dim fhFile As Integer
Dim bof1 As BOF
Dim eof1 As EOF
Dim l1 As tLabel
Dim i1 As tInteger
Dim n1 As tNumber

Private Sub Class_Initialize()
  'Set up default values for records
  'These should be the values that are the same for every record

  With bof1
    .opcode = 9
    .Length = 4
    .Version = 2
    .ftype = 10
  End With

  With eof1
    .opcode = 10
  End With

  With l1
    .opcode = 4
    .Length = 10
    .Row = 0
    .col = 0
    .rgbAttr1 = 0
    .rgbAttr2 = 0
    .rgbAttr3 = 0
    .strLength = 2
  End With

  With i1
    .opcode = 2
    .Length = 9
    .Row = 0
    .col = 0
    .rgbAttr1 = 0
    .rgbAttr2 = 0
    .rgbAttr3 = 0
    .Value = 0
  End With

  With n1
    .opcode = 3
    .Length = 15
    .Row = 0
    .col = 0
    .rgbAttr1 = 0
    .rgbAttr2 = 0
    .rgbAttr3 = 0
    .Value = 0
  End With

End Sub

Public Sub OpenFile(ByVal FileName As String)
  fhFile = FreeFile
  Open FileName For Binary As #fhFile
  Put #fhFile, , bof1
End Sub

Public Sub CloseFile()
  Put #fhFile, , eof1
  Close #fhFile
End Sub

Function EWriteString(ExcelRow As Integer, ExcelCol As Integer, Text As String)
  Dim b As Byte, l As Byte, a As Byte
'Length of the text portion of the record
  l = Len(Text)
  l1.strLength = l

'Total length of the record
  l1.Length = 8 + l1.strLength

  l1.Row = ExcelRow - 1
  l1.col = ExcelCol - 1

'Put record header
  Put #fhFile, , l1

'Then the actual string data
'We have to write the string one character at a time, so we loop
'through all characters in the string, assign thier ASCII value to b
'and do a Put on b (which is declared as Byte)
  For a = 1 To l
    b = Asc(Mid$(Text, a, 1))
    Put #fhFile, , b
  Next

End Function

Function EWriteInteger(ExcelRow As Integer, ExcelCol As Integer, Value As Integer)
  With i1
    .Row = ExcelRow - 1
    .col = ExcelCol - 1
    .Value = Value
  End With

  Put #fhFile, , i1
End Function

Function EWriteDouble(ExcelRow As Integer, ExcelCol As Integer, Value As Double)
  With n1
    .Row = ExcelRow - 1
    .col = ExcelCol - 1
    .Value = Value
  End With

  Put #fhFile, , n1
End Function

Y esta Function en un Modulo:

Código: (VB) [Seleccionar]

Public Function Rst2Excel(sFileName As String, Rec As ADODB.Recordset) As Boolean
On Error GoTo ErrFnc
Dim fExcel As xlsV2
Dim lRow As Integer, lCol As Integer
Dim excelDouble As Double
Dim rowOffset As Long
     
Set fExcel = New xlsV2
     
With fExcel
  .OpenFile sFileName
  ' Cabeceras
     For lCol = 1 To Rec.Fields.Count
       .EWriteString lRow + rowOffset, lCol, Rec.Fields(lCol - 1).Name
     Next lCol
  ' ----------------------------------------------------
  ' Datos
   Do While Not Rec.EOF
      lRow = lRow + 1 ' Añade una nueva fila
      For lCol = 1 To Rec.Fields.Count
         If IsNumeric(Rec.Fields(lCol - 1).Value) Then
           excelDouble = CDbl(Rec.Fields(lCol - 1).Value) + 0
           .EWriteDouble lRow + rowOffset, lCol, excelDouble
         Else
           .EWriteString lRow + rowOffset, lCol, Rec.Fields(lCol - 1).Value
         End If
      Next lCol
      ' -- Siguiente registro
      Rec.MoveNext
   Loop
  ' ----------------------------------------------------
               
  .CloseFile
End With
  Rst2Excel = True

Exit Function
ErrFnc:
Rst2Excel = False
End Function

Y lo llamas así:

Código: (VB) [Seleccionar]

 
  Cnn.Open SQLConn    '<--- Abre Conexion
  Rst.Open ConsultaSQL, Cnn, adOpenDynamic, adLockOptimistic   '<--- Abre Recordset
  ' -------------------
  ' Pasar Recordset a Excel...
  Call Rst2Excel(App.Path & "\EXCELTEST.XLS", Rst)
  ' -------------------
  Rst.Close

Saludos Cordiales

[raul338]

Noooo
Pucha si alguien tiene algo armado seria bueno igual como raul quiza mandando directamente la parte comentada la cual es para versiones antiguas de excel aunque lo dudo, saludos

Que sea viejo no quiere decir que no funcione
Para mí ese código comentado funciona igual e.e

igual de todas formas tengo este codigo que en realidad pasa un MSHFlexGrid pero no cuesta nada pasarlo a un recordset

Código: (vb) [Seleccionar]

Dim oExcel As Object, wb As Object, hoja As Object
Set oExcel = CreateObject("Excel.Application")
Dim Fila As Long
Dim Columna As Long

Set wb = oExcel.Workbooks.Add
Set hoja = wb.Worksheets.Add

Dim filaExcel As Long
filaExcel = 1

With LV
For Columna = 1 To .Cols - 1
filaExcel = 1
For Fila = 0 To .Rows - 1
hoja.cells(Fila, Columna).Value = .TextMatrix(Fila, Columna)
' Si es numero o fecha tienes que convertirlo directo: Ejemplo
'hoja.cells(filaExcel, Columna).Value = CCur(.TextMatrix(Fila, Columna))
Next
hoja.Columns(Columna).AutoFit
Next
End With

oExcel.Visible = True
Set oExcel = Nothing
Set wb = Nothing
Set hoja = Nothing

Lo probe usando Office 2010. Deberia funcionar con cualquier version superior a la 2000

[Waldo]

Lo que tambien se puede hacer es guardar datos en una hoja excel, pero sin usar los objetos de excel, sino usando directamente ADO, indicando en el connectionstring que se va a trabajar con un excel. La ventaja de hacerlo con ADO directamente, es que en la maquina que corre no necesita tener un excel instalado. no tengo a mano un ejemplo, pero si buscas ado excel seguro algo aparece.
Para insertar datos, es tal cual como con una base
INSERT INTO Hoja1$ (col1,col2,col3) VALUES ( val1,val2,val3)