Visual Basic Foro
Programación => Bases de Datos => Mensaje iniciado por: lucius en Junio 15, 2010, 12:16:16 am
-
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
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
' ------------------------------------------------------------------------------------
' \\ -- 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
-
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...!
-
Bueno he leido por ahi que asi se llama cuando se utiliza shape, append, relate dentro de la consulta para agrupar registros asi:
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?.
-
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...!
-
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 (http://www.megaupload.com/?d=43POTG5Y)
saludos
-
Dentro de tu funcion Exportar_Excel, con esto recorres el detalle:
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
-
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
-
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:
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
-
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
-
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
-
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...
-
Bueno, este es mi aporte por si alguien lo quiere en vertical.
http://www.4shared.com/file/jt-mC7qY/Exportar_recordsetVert.html
-
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.
' ------------------------------------------------------------------------------------
' \\ -- 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