Newsgroup: it.comp.lang.visual-basic
Titolo: Esportazione di dati

Ciao a tutti...
Avrei bisognodi un'informazione:
Come si fà ad esportare una tabella o un query di Access in un file ad
esempio .xls da codice?
grazie in anticipo...Raf

 ha scritto nel messaggio
news:a1cppb$10s$1...@pegasus.tiscalinet.it...

codice trovato sulla rete
pero' xl deve esserci...
bar e' una progressbar
--
ciao, j.
www.sundaysw.com
Option Explicit
Private Sub CmdExport_Click()
'This code exports a recordset to an excel spreadsheet
    Dim x
    Dim xlApp As Excel.Application
    Dim xlBook As Workbook
    Dim xl As Excel.Worksheet
    Dim icols
    Dim expDB As Database
    Dim rs As Recordset
    Dim FldCount As Integer
    Dim rsCount As Integer
    Dim i, k, c, r
    x = MsgBox("This function will export the current records in the DBGrid
to an Excel sheet, " & _
        "If you do not have Excel an error will occur, do wish to
continue?", vbYesNo + vbQuestion, "Export Data?")
    If x = vbNo Then Exit Sub
    'If IsNull(tmpData.Recordset) Then GoTo NoRS
    Screen.MousePointer = vbHourglass
    'Access Your recordset here it is from as
    'Data control, it does not maatter where it
    'comes from.
    Dim lstDB As Database
    Set lstDB = OpenDatabase("iching97")
    Set rs = lstDB.OpenRecordset("esagrammi", dbOpenSnapshot)
    'Set rs = lstDB.OpenRecordset(tmpData.RecordSource, dbOpenSnapshot)
    'Declare application
    Set xlApp = CreateObject("Excel.Application")
    'Declare Workbook
    Set xlBook = xlApp.Workbooks.Add(xlWBATWorksheet)
    'Identify worksheet
    Set xl = xlBook.Worksheets(1)
    'Below this code determines the number of columns then
    'labels each column with the appropriate field name.
    'This code can be found in the 'CopyFromRecordSet' function
    'of the Excel Object.
    FldCount = rs.Fields.Count - 1
    'Excel Column counts are kept seperate as fields may be skipped
    c = 1
    For icols = 0 To rs.Fields.Count - 1
    'If the field is a system field then it skips it.
        If rs.Fields(icols).Name Like "s_" & Chr(42) Then GoTo SkipName
        xl.Cells(1, c).Value = rs.Fields(icols).Name
        c = c + 1
SkipName:
    Next
    xl.Range(xl.Cells(1, 1), xl.Cells(1, rs.Fields.Count)).Font.Bold = True
    With rs
        .MoveLast
        .MoveFirst
        rsCount = .RecordCount - 1
        r = 2
        Me.Height = 5970
        'Here I have a statusbar on my form
        Bar1.Min = 0
        Bar1.Max = rsCount
        lblExport.Visible = True
        Bar1.Visible = True
        '4 loops are being performed at once here.
        'Loop 'k' loops through the rows of records and
        'with each row 'r' for the Excel sheet.
        'Inside this loop is another nested loop.
        'Loop 'i' is looping through the Fields and along
        'with i 'c' is moving through the columns.
        'As mentioned above the reason for seperate counts
        'between the recordset and Excel sheet are due to
        'skipping system fields.
        For k = 0 To rsCount
            c = 1
            For i = 0 To FldCount
                If rs.Fields(i).Name Like "s_" & Chr(42) Then GoTo SkipField
                xl.Cells(r, c).Value = rs.Fields(i).Value
                c = c + 1
SkipField:
            Next 'i
            r = r + 1
            .MoveNext
            Bar1.Value = k
        Next 'k
    End With
    'After loop is complete, show the sheet
    xl.Visible = xlSheetVisible
    xlApp.Visible = True
    Bar1.Visible = False
    lblExport.Visible = False
    Me.Height = 5265
    xlApp.Quit
    Set xl = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Set rs = Nothing
    Screen.MousePointer = vbDefault
    Exit Sub
NoRS:
    Screen.MousePointer = vbDefault
    MsgBox "No Active recordset detected"
    Exit Sub
Exp_Err:
    Screen.MousePointer = vbDefault
    MsgBox Err.Number & ": " & Err.Description
    Resume Next
End Sub

 > Come si fŕ ad esportare una tabella o un query di Access in un file ad


 Ciao e grazie
scusa Cesare, ma quotare no? :-(
Saluti
--
Stefano Zamboni 
sz...@libero.it
Seconda legge di Scott:
Quando si trova e si corregge un errore, si vedrŕ che andava meglio prima.


Di solito uso questa procedura per esportare su excel a partire __da un
recordset Ado__ qualunque:
Sub ToExcel(rsData As ADODB.Recordset, sName As String)
    Dim TempArray()
    Dim exclApp As Object
    Dim WKS As Object
    Dim NN, KK As Integer
    Dim nFieldsCount, nRecordCount As Long
    On Error GoTo err
    'Rettifico il Nome Foglio
    sName = Replace(Replace(Replace(sName, ":", ""), "\", ""), "/", "")
    sName = Replace(Replace(Replace(Replace(sName, "?", ""), "*", ""), "[",
""), "]", "")
    Lancio Excel
    Set exclApp = GetObject(, "Excel.Application")
resuming:
    'preparo Excel
    With exclApp
        .Visible = True
        With .activeWorkbook
            Set WKS = .Worksheets.Add
            For NN = 1 To .Sheets.Count
                If sName = .Sheets(NN).Name Then
                    sName = sName + "-nuovo"
                End If
            Next NN
        End With
    End With
    sName = Left(sName, 31)
    With WKS
        .cells.Delete
        .cells(1, 1) = App.FileDescription & "  " & Programma.Release & " -
Esportazione Dati."
        .cells(2, 1) = "Attendere, lettura dati in corso: " & sName
    End With
    With rsData
        nFieldsCount = .Fields.Count
        nRecordCount = .RecordCount
    End With
    If nRecordCount = 0 Then
        With WKS
            .cells(4, 1) = "NESSUN dato disponibile"
            .cells(4, 1).Font.Bold = True
        End With
    Else
        'Riporto il Recordset su Un Array, per pulire i NULL
        ReDim TempArray(1 To nRecordCount, 1 To nFieldsCount)
        For NN = 1 To nRecordCount
            WKS.cells(4, 1) = "Conversione in corso record: " & str(NN) & "
/ " & nRecordCount
            DoEvents
            For KK = 1 To nFieldsCount
                If IsNull(rsData(KK - 1)) Then
                    TempArray(NN, KK) = Empty
                ElseIf VarType(rsData(KK - 1)) = vbString And
Left(rsData(KK - 1), 1) = "=" Then
                    TempArray(KK, KK) = "'" + rsData(KK - 1)
                Else
                    TempArray(NN, KK) = rsData(KK - 1)
                End If
            Next KK
            rsData.MoveNext
        Next NN
        'Carico lo sheet con i dati
        With WKS
            For KK = 0 To nFieldsCount - 1
                .cells(1, KK + 1).Value = rsData.Fields(KK).Name
            Next KK
            .Range(WKS.cells(1, 1), WKS.cells(1, nFieldsCount)).Font.Bold =
True
            'WK.Range("A2").CopyFromRecordset rsData
            .Range("A2").Resize(rsData.RecordCount,
rsData.Fields.Count).Value = TempArray
            .cells(2, 1).Activate
            For KK = 0 To nFieldsCount - 1
                .Columns.AutoFit
            Next KK
            .Name = sName
        End With
    End If
    'Chiusura degli oggetti aperti
    rsData.Close
    Set rsData = Nothing
    Set exclApp = Nothing
    Set WKS = Nothing
    Screen.MousePointer = 0
    Exit Sub
err:
    If err = 429 Then
        err.Clear   ' Clear Err object
        Set exclApp = CreateObject("Excel.Application")
        exclApp.Workbooks.Add
        Resume resuming
    Else
        ShowErrMsg
    End If
    Screen.MousePointer = 0
End Sub
ciao
ugo

 > codice trovato sulla rete
ho riprovato quel codice con circa 95k record e in effetti e' mooolto lento
(con un 800mhz). non so se si blocca x' l'ho terminato.
ho provato a esportare la stessa tabella in csv separato da tab.
(ho provato anche con il csv classico, ma xl2k da me coi csv si incasina, ed
e' successo anche questa volta. devo reinstallarlo. grazie bill).
col codice sotto i 95k li ha esportati in pochi secondi, e access il .tab se
lo legge beatamente.
nb: col csv classico access (italiano) manda strani messaggi di protesta (in
inglese) che il separatore corrisponde al decimale e si rifiuta. di qui la
scelta del chr(9).
se hai un excel funzionante, i .csv appaiono come associati a xl. se pero'
si incasina anche a te non dirmi niente e non pensare a me ma a bill...
ciao, j.
Private Sub Command1_Click()
    Dim db As Database, rs As Recordset
    Dim fName As String, fNum As Integer
    Dim j As Long, f As Long, r As Long, c As Long, s As String
    Set db = OpenDatabase("db1.mdb")
    Set rs = db.OpenRecordset("test_tab", dbOpenSnapshot)
    'fName = App.Path & "\db1.csv"
    fName = App.Path & "\db1.tab"
    fNum = FreeFile
    Open fName For Output As #fNum
    With rs
        f = .Fields.Count - 1
        For j = 0 To f
            s = s & .Fields(j).Name & Chr(9)
        Next
        s = Left(s, Len(s) - 1)
        Print #fNum, s
'        s = ""
'        For j = 0 To f
'            s = s & "riga1_" & CStr(j) & Chr(9)
'        Next
'        s = Left(s, Len(s) - 1)
'        Print #fNum, s
        .MoveLast
        r = .RecordCount
        If r = -1 Then r = 0
        .MoveFirst
        While Not .EOF
            s = ""
            For j = 0 To f
                s = s & .Fields(j) & Chr(9)
            Next
            s = Left(s, Len(s) - 1)
            Print #fNum, s
            c = c + 1
            lblExport = c & " / " & r
            If c Mod 100 = 0 Then DoEvents
            .MoveNext
        Wend
    End With
    Close #fNum
    rs.Close: Set rs = Nothing
    MsgBox "ok"
End Sub