Exportar recordset jerarquico a excel - Ayuda para modificar funcion

[lucius]

Tengo una funcion que seguro ya habran visto y quisiera modificarla para que acepte recordset's jerarquicos pero no he podido lograrlo espero puedan ayudar

Código: [Seleccionar]

Private Sub Command5_Click()
Dim Cn As ADODB.Connection
Dim rs As New ADODB.Recordset

sSQL = "SHAPE {SELECT codcat,nomcat FROM categoria} AS cabecera " & _
"APPEND ({SELECT codprod,nomprod,precioventa,codcat FROM producto} AS detalle " & _
"RELATE codcat TO codcat) AS detalle"

Set Cn = New ADODB.Connection
Cn.Provider = "MSDataShape"
Cn.Open "Data Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\bd_01.mdb"

Set rs = New ADODB.Recordset
rs.StayInSync = False
rs.Open sSQL, Cn

Call Exportar_Excel(rs)

End Sub
Funcion

Código: [Seleccionar]

' ------------------------------------------------------------------------------------
' \\ -- Función para exportar el recordset ADO a una hoja de Excel
' ------------------------------------------------------------------------------------
Public Function Exportar_Excel(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
       
    'Me.Enabled = False
    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
    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
               
        ' -- 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
    ' -- Elimina las referencias xls
    Set Hoja = Nothing
    Set Libro = Nothing
    'Excel.quit
    Set Excel = Nothing
       
    Exportar_Excel = True
    'Me.Enabled = True
    Screen.MousePointer = 0
    Exit Function
errSub:
    MsgBox Err.Description, vbCritical, "Error"
    Exportar_Excel = False
    'Me.Enabled = True
    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

saludos

[ssccaann43]

A que te refieres con recordset jerarquico? Ordenado? De ser ordenado en el Select, aplica el Order by (asc o desc) depende de como desees...!

[lucius]

Bueno he leido por ahi que asi se llama cuando se utiliza shape, append, relate dentro de la consulta para agrupar registros asi:

Código: [Seleccionar]

categoria 1
producto1
producto2

categoria 2
producto3
producto4

categoria 3
producto5

[Editado]La funcion que tengo solo envia a excel las cabeceras(categorias)  y NO detalles(productos)

Si la consulta fuera select*from productos si lo hace correctamente ya que la funcion esta diseñada para enviar solo filas o no?.

[ssccaann43]

Pero puedes hacer un ciclo, donde envias inicialmente la cabecera, sacandola de un select, y luego mandas el producto...! Creo que metiendole unos For bastaria para ello...!

[lucius]

Lo que exporta son las cabeceras mas no los detalles, he probado pero no he podido, voy a ver si puedo solucionarlo.
Dejo el ejemplo haber si alguien se anima a resolverlo
http://www.megaupload.com/?d=43POTG5Y

saludos

[YAcosta]

Dentro de tu funcion Exportar_Excel, con esto recorres el detalle:

Código: (vb) [Seleccionar]

Dim rsDet As Variant 
     
Do While Not rec.EOF
   rsDet = rec("LEVEL2")
   While Not rsDet.EOF
      a = rsDet.Fields(1)
      rsDet.MoveNext
   Wend
   rsDet.Close
   rec.MoveNext
Loop

Pero la verdad no se como enviarlo a Excel, voy a seguir probando, pero si lo logras hacer te agradecería mucho lo publicases

[lucius]

YvanB, he intentado de varias formas y el codigo que dejas para recorrer el detalle devuelve cabeceras y detalles mas no los detalles solos, lo he probado seteando el rsDet en un Hierarchical flexgrid, si pudieras ayudarme con eso creo que podria lograrlo espero no haberme equivocado, saludos

[YAcosta]

Hola
Lamentablemente no lo he podido resolver, estuve dando vueltas a ese tema y me parece que debe haber alguna limitación en el método CopyFromRecordset que al parecer no admite recordset jerarquicos, no podria asegurarlo pero como sabes ni siquiera envía los encabezados, por eso tu mismo haces esto:

Código: (vb) [Seleccionar]

For iCol = 1 To rec.Fields.Count
      Hoja.Cells(1, iCol).Value = rec.Fields(iCol - 1).Name
Next y luego ya envias la data.

No creo que la solución sea armar a mano (una tabla intermedia con cabecera y detalle) lo que se envia en CopyFromRecordset. Seguira checando

[k_arlytos]

lo que eh visto por ahi que cada shape te da como resultado un recordset
lo probe hace poco tenia dos tablas una de productos y otro categoria
y cuando hacia un rs.field(1)
me devolvia el dato de los productos mas no de categoria y no sabia como meterme a las categorias
pero buscando y buscando llegue a sacar los datos de la categoria
suponte q mi shape es
    Dim sql As String
    sql = "SHAPE {select productid,productname from products} AS DT" _
          + " APPEND ({select orderid,productid,unitprice,quantity from [order details]} AS P RELATE productid TO productid) "

y eso lo metia en un rs
rs.open sql,cnx
y para capturar los datos de categoria lo hice con
dim rstmp as variant
rstmp=rs(P )

    Do While Not rs.EOF
       Debug.Print rstmp.Fields(1)
       rs.MoveNext
    Loop
y eso me imprimia los datos de las categorias

y bueno en tu casa creo q ya capturando ya el detalle ya harias un bucle no

espero q te sirva de algo saludos

[k_arlytos]

bueno aqui otra vez quise intentar lo q dije arriba y bueno espero q esta sea tu solucion
jaja no sabia como subir archivos ala web
http://www.megaupload.com/?d=3FDOL40D

[YAcosta]

bueno aqui otra vez quise intentar lo q dije arriba y bueno espero q esta sea tu solucion
jaja no sabia como subir archivos ala web
http://www.megaupload.com/?d=3FDOL40D

jeje, ta buena k_arlitos, ahora seria interesante lograr que la lista vaya para abajo, quiza despues de poner lo de PROCESADORES contando los registros de su detalle y sumandole uno podamos pocisionarnos por ejemplo en la sexta fila. y Asi con el segundo detalle.
Voy a probar...

[YAcosta]

Bueno, este es mi aporte por si alguien lo quiere en vertical.

http://www.4shared.com/file/jt-mC7qY/Exportar_recordsetVert.html

[lucius]

Hace varios dias que no ingreso a internet, veo que se animaron a resolverlo gracias por el codigo k_arlytos e YvanB, aunque no se ven los codcat y codprod espero poder resolver eso sin problemas.
Dejo el codigo de la funcion para los que no quieren descargar.

Código: [Seleccionar]

' ------------------------------------------------------------------------------------
' \\ -- Función para exportar el recordset agrupado con SHAPE a una hoja de Excel
' ------------------------------------------------------------------------------------
Public Function Exportar_Excel(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
    iCol = rec.Fields.Count
   
   '-----------------------------------------------------------------------------
    'Me da como resultado la cabeceras de la tabla
    Dim x As Variant, y As Integer
    Dim i As Byte
   
    Dim Fila   As Integer
    Dim Posic  As Integer
    i = 1
    Fila = 1
    Posic = 1
    Do While Not rec.EOF
        Hoja.Cells(Fila, 1).Value = rec.Fields(1).Value
        x = rec("LEVEL2")
        For Fila = 1 To x.RecordCount
            Hoja.Cells(Fila + Posic, 1).Value = x.Fields(1)
            x.MoveNext
        Next Fila
        rec.MoveNext
        Fila = Fila + Posic + 1
        Posic = Fila
    Loop
    Excel.Selection.CurrentRegion.Columns.AutoFit
    Excel.Selection.CurrentRegion.Rows.AutoFit
   
    'Hoja.Name = ""
    'Libro.saveAs App.Path & "\libro"
    'Libro.Close
    ' -- Elimina las referencias xls
    Set Hoja = Nothing
    Set Libro = Nothing
    'Excel.quit
    Set Excel = Nothing
       
    Exportar_Excel = True
    Screen.MousePointer = 0
    Exit Function
errSub:
    MsgBox Err.Description, vbCritical, "Error"
    Exportar_Excel = 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