www.lawebdelprogramador.com
RESPUESTA A LA PREGUNTA 14201 - VISUAL BASIC


'take data from a VB database application and place it into 'an 'Excel 'spreadsheet


Private Sub Excel_Spreadsheet(rst As Recordset)

'Declare all Excel objects

Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlWS As Excel.Worksheet

Set xlApp = New Excel.Application
Set XLWB = xlApp.Workbooks.Add
Set xlWS = xlWB.Worksheets.Add

'Fill cells using recordset
xlWS.Cells(1,1).Value = rst("Field1")
xlWS.Cells(2,1).Value = rst("Field2")

' save spreadsheet
xlWS.SaveAS "mysheet.xls"
xlApp.Quit

' Free memory
Set xlWS = Nothing
Set xlWB = Nothing
Set xlApp = Nothing

End Sub


Tambien aqui te envio el codigo para covertir Exel para MS Access DB

'This is an 'as is' program
'I don't responsible if something weird happens
'If you found bug please let me know : drop_me@hotmail.com
'This version just handles excel to excess
'
'To use this .dll, just go to project, references, the locate Conversion.dll
'
'Property that you have to setup:
'    Dim myConv As Object
'    Dim boolResult As Boolean

'    Dim myConv As Object

'    Set myConv = New DoConversion
    
'    With myConv

'        .Filename = "blablabla"         just excel filename without .xls
'        .XLSFilename = "blablabla.xls"  excel file name
'        .Sheetname = "blabla"           excel sheet name
'        .ExcelDir = "c:\xls\"           anything you like
'        .AccessDir = "c:\access\"       anything you like
'        .InitialField = "Description"   start from what variable
'                                        do you want to convert
'        .MaximumCol = 15                to detect max col
'        .AccessVersion = 2
'        .ConvertType = 1
'    boolResult = .Execute()
    
'    If boolResult = True Then
'        lstResult.AddItem "Status : OK"
'    Else
'        lstResult.AddItem "Status : Fail"
'    End If
    
'    End With
    
'    Set myConv = Nothing

'For ConvertType, only value 1 available
'For AccessVersion -> 0 for old office, 1 for office 97, 2 for office 2000

'Declarations
'Sample program :
Private Sub Command1_Click()
    Dim boolResult As Boolean
    Dim myConv As Object
    Dim Directory As String

    Directory = Left$(App.Path, 3)
    
    Set myConv = New DoConversion
    
    With myConv

        .FileName = "Chemistry"
        .XLSFilename = "Chemistry.xls"
        .Sheetname = "Chemlist"
        .ExcelDir = Directory
        .AccessDir = Directory
        .InitialField = "Chemical Name"
        .MaximumCol = 15
        .AccessVersion = 2
        .ConvertType = 1
    
        boolResult = .Execute()
    
        If boolResult = True Then
            MsgBox ("Status : OK")
        Else
            MsgBox ("Status : Fail")
        End If
    
    End With
    
    Set myConv = Nothing
    
End Sub



Dim L_XLSFname As String
Dim TypeConvert As Integer
Dim L_Fname As String
Dim L_Sname As String
Dim X_Dir As String
Dim A_Dir As String
Dim StartFrom As String
Dim MaxCol As Integer
Dim TypeAccess As String
Dim LastResult As Boolean

Public Property Let XLSFilename(ByVal O_XLSFname As String)
    L_XLSFname = O_XLSFname
End Property
Public Property Let Filename(ByVal O_Fname As String)
    L_Fname = O_Fname
End Property
Public Property Let Sheetname(ByVal O_Sname As String)
    L_Sname = O_Sname
End Property
Public Property Let ExcelDir(ByVal O_Xdir As String)
    X_Dir = O_Xdir
End Property
Public Property Let AccessDir(ByVal O_Adir As String)
    A_Dir = O_Adir
End Property
Public Property Let InitialField(ByVal O_Start As String)
    StartFrom = O_Start
End Property
Public Property Let AccessVersion(ByVal O_AccVer As Integer)
    TypeAccess = O_AccVer
End Property
Public Property Let MaximumCol(ByVal nCol As Integer)
    MaxCol = nCol
End Property
Public Property Let ConvertType(ByVal nType As Integer)
    TypeConvert = nType
End Property

Public Function Execute() As Boolean
    LastResult = True
    
    Duplicate
    Execute = LastResult
End Function

Private Function Duplicate()
On Error GoTo finish

    Dim MyWs As Workspace
    Dim MyDb As Database
    Set MyWs = DBEngine.Workspaces(0)
    
    Select Case TypeConvert
        Case 1
            If Dir(A_Dir & L_Fname & ".mdb") <> "" Then
                Kill (A_Dir & L_Fname & ".mdb")
            End If
            Select Case TypeAccess
                Case 0
                    Set MyDb = MyWs.CreateDatabase(A_Dir & L_Fname & ".mdb", dbLangGeneral, dbVersion40)
                Case 1
                    Set MyDb = MyWs.CreateDatabase(A_Dir & L_Fname & ".mdb", dbLangGeneral, dbVersion50)
                Case 2
                    Set MyDb = MyWs.CreateDatabase(A_Dir & L_Fname & ".mdb", dbLangGeneral, dbVersion60)
                Case Else
                    LastResult = False
            End Select
            Set MyWs = Nothing
            Set MyDb = Nothing
            DoExcelAccess
        Case Else
    End Select
    
    If LastResult = True Then GoTo done

finish:
    If Dir(A_Dir & L_Fname & ".mdb") <> "" Then
                Kill (A_Dir & L_Fname & ".mdb")
    End If
    LastResult = False
    
done:
    

End Function

Private Function DoExcelAccess()
On Error GoTo finish
Dim cnn As New ADODB.Connection
Dim path As String
Dim Sheet As Object
Dim r, y, x, n, count As Integer
Dim Xstart, Ystart, Xend, Yend, tempX, tempY As Integer
Dim flagX As Boolean
Dim flagY As Integer
Dim XFields() As String
Dim Fieldname, ans As String
Dim LengthField As Integer
Dim Query As String
Dim Combined As String
Dim aByte As String
Dim LengthCombined As String
Dim ComResult As String

path = X_Dir & L_XLSFname

If Dir(path) = "" Then
     MsgBox (path & " doesn't exist.")
     LastResult = False
End If

If LastResult = False Then GoTo finish

flagX = True

    Set Sheet = GetObject(path, "Excel.Sheet.8") 'assign sheet object as an OLE excel

    With Sheet.Worksheets(L_Sname)

    y = 1
    z = 0
    flagY = 1
    Xstart = 0
    Xend = 0
    Ystart = 0
    Yend = 0
    count = 0
    Fieldname = ""
    ReDim XFields(count)
    
    Do While True
        If flagX = True Then
            For x = 1 To MaxCol
                If Trim(LCase(.cells(y, x).Value)) = LCase(StartFrom) And flagX = True Then
                    Xstart = x
                    Ystart = y
                    tempX = x
                    tempY = y
                    Do While True
                        If Trim(.cells(tempY, tempX).Value) = "" Then
                            Xend = tempX - 1
                            Exit Do
                        End If
                        tempX = tempX + 1
                    Loop
                    flagX = False
                    Exit For
                End If
            Next
            If flagX = True And y = 20 * flagY Then
                ans = MsgBox("MyInventory couldn't find " & StartFrom & _
                      " up to line " & y & ". Continue?", vbYesNo + vbQuestion)
                If ans = vbNo Then
                    MsgBox ("Go to Property to fix this error.")
                    LastResult = False
                    Exit Do
                End If
                flagY = flagY + 1
            End If
        Else
            For n = Xstart To Xend
            
                ComResult = ""
                
                aByte = ""

                Combined = Trim(.cells(Ystart, n).Value)
                
                LengthCombined = Len(Combined)
                    
                For r = 0 To LengthCombined
                    aByte = Mid(Combined, r + 1, 1)
                    If aByte <> ")" And aByte <> "(" And aByte <> "." And aByte <> " " And aByte <> "#" Then
                            ComResult = ComResult & aByte
                    End If
                Next r

                XFields(count) = Trim(ComResult)
                
                Fieldname = Fieldname & " " & Trim(ComResult) & " Text(150)" & ","

                count = count + 1
                
                ReDim Preserve XFields(count)

           Next
           
           LengthField = Len(Trim(Fieldname))
           
           Fieldname = Left(Trim(Fieldname), LengthField - 1)
           
           If LengthField > 0 Then
                Query = "Create Table " + L_Sname + " ( " + Fieldname + " )"
                cnn.Open "provider=microsoft.jet.oledb.4.0;data source=" & A_Dir & L_Fname & ".mdb"
                cnn.Execute Query
                Exit Do
           Else
                MsgBox ("Undefined error.")
                LastResult = False
                Exit Do
           End If
        
        End If
        
        y = y + 1
        
    Loop
    
    If LastResult = False Then GoTo finish
    
    Dim dataRec As ADODB.Recordset
    
    Set dataRec = New ADODB.Recordset
   
    dataRec.Open L_Sname, cnn, adOpenStatic, adLockOptimistic, adCmdTable
    
    Ystart = Ystart + 1
     
    Do While True
        If .cells(Ystart, Xstart) = "" Then
            Exit Do
        End If
        z = Xstart
        dataRec.AddNew
        For x = 0 To count - 1
            dataRec(XFields(x)) = .cells(Ystart, z).Value
            z = z + 1
        Next
        dataRec.Update
        Ystart = Ystart + 1
    Loop
    
    End With

    Set dataRec = Nothing
    Set cnn = Nothing
    Set Sheet = Nothing
    
    If LastResult = True Then GoTo done
    
    
finish:
    If Dir(A_Dir & L_Fname & ".mdb") <> "" Then
                   Kill (A_Dir & L_Fname & ".mdb")
    End If
    LastResult = False
    
done:
    Set dataRec = Nothing
    Set cnn = Nothing
    Set Sheet = Nothing
    
End Function

Espero que sirva


Oswaldo Monagas
oswaldomonagas@hotmail.com