Visual Basic Foro
Programación => Visual Basic 6 => Mensaje iniciado por: lucius en Octubre 16, 2014, 09:19:11 pm
-
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.
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
-
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
-
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.
-
Noooo :o
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
-
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:
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:
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í:
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
-
Noooo :o
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 :P
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
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
-
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)