Newsgroup: it.comp.lang.visual-basic
Titolo: Modifica Ado2Excel...

Ciao a tutti,
ho trovato questo progetto per esportare dati da un recordset ad excel.
Mi pare forse sul sito comune...
In ogni caso, ho notato che usando DB interbase la routine da problemi
nell'esportazione di campi numerici/decimal, nel senso che da errore e non
esporta nulla, o una parte dei dati.
Se interessa a qualcuno (domani se ce la faccio) posto le modifiche fatte
per farla andare anche in questi casi.
Ciao :)

Andrea ha scritto:

potresti inviarla al sito comune dall'apposito modulo.
bye
-- 
Gestione Ottica - Gestionale per Ottici e Programmi Gratuiti su:
http://www.nicolaottomano.it
Sinapsi Antispam. Antispam Gratuito.
http://www.nicolaottomano.it/sinapsi.htm
email spamtrap: 
spam...@nicolaottomano.it

 potresti inviarla al sito comune dall'apposito modulo.
Intanto lo incollo qui va... :)
Spero di aver tolto tutta la roba aggiuntiva "esterna".
In pratica invece di trasferire la matrice, ho fatto campo per campo, a
seconda del tipo.
Ciao :)
*****
Sub Ado2Excel(rsData As ADODB.Recordset, sName As String, sPath As String,
bCheck As Boolean)
    ' Parametri:
    ' rsData - Recordset ADO da esportare
    ' sName  - nome da assegnare allo sheet di excel
    ' bCheck - eseguire un controllo sui dati
    '
    Dim TempArray() As String
    Dim VetTypeDB() As Integer 'Mi prendo il tipo di ogni campo stampato es.
vet(0)=integer vet(1)=string ecc.
    Dim TempArrayNUM() As Double   'Vettore temporaneo per i numeri
    Dim TempArraySTR() As String 'Vettore temporaneo per i NOT numeri
    Dim exclApp As Object
    Dim WKS As Object
    Dim j, NN, KK As Integer
    Dim nFieldsCount As Integer, nRecordCount As Long
    On Error GoTo err
    Screen.MousePointer = vbHourglass
    'Rettifico il Nome Foglio (giusto per dormire tranquillo!):
    sName = Replace(Replace(Replace(sName, ":", ""), "\", ""), "/", "")
    sName = Replace(Replace(Replace(Replace(sName, "?", ""), "*", ""), "[",
""), "]", "")
    'dichiaro una variabile excel.application
    Set exclApp = GetObject(, "Excel.Application")
    '...e in caso di errore gestisco l'errore e apro excel...
Resuming:
    With exclApp
        .Visible = True
        With .ActiveWorkbook
            Set WKS = .Worksheets.Add
            ' Verifico se già esiste un foglio con lo stesso nome
            For NN = 1 To .Sheets.Count
                If sName = .Sheets(NN).Name Then
                    sName = sName + "-nuovo"
                End If
            Next NN
        End With
    End With
    'Assumo comunque che mi bastino 31 char...
    sName = Left(sName, 31)
    With WKS
        .Cells.Delete
        .Cells(1, 1) = App.Title & "  " & App.Major & "." & App.Minor & "."
& Trim(App.Revision) & " - 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
        If bCheck Then
            'Riporto il Recordset su Un Array, per pulire i NULL ed altro
            ReDim TempArray(1 To nRecordCount, 1 To nFieldsCount) As String
            ReDim TempArrayNUM(1 To nRecordCount, 1 To 1) As Double
            ReDim TempArraySTR(1 To nRecordCount, 1 To 1) As String
            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
                        ' Pulisco i NULL
                        TempArray(NN, KK) = Empty
                    ElseIf VarType(rsData(KK - 1)) = vbString And
Left(rsData(KK - 1), 1) = "=" Then
                        ' Pulisco gli "="
                        TempArray(KK, KK) = "'" + rsData(KK - 1)
                    Else
                        TempArray(NN, KK) = rsData(KK - 1)
                    End If
                Next KK
                rsData.MoveNext
            Next NN
        End If
        'Carico lo sheet con i dati
        With WKS
            ReDim VetTypeDB(0 To nFieldsCount - 1) As Integer
'###Carico nel vettore il tipo di campo e il Name per l'intestazione
            For KK = 0 To nFieldsCount - 1
              VetTypeDB(KK) = rsData.Fields(KK).Type
              .Cells(1, KK + 1).Value = rsData.Fields(KK).Name
            Next KK
            .Range(WKS.Cells(1, 1), WKS.Cells(1, nFieldsCount)).Font.Bold =
True
            If Not bCheck Then
                'Se non è richiesto il controllo uso il metodo standard
                .Range("A2").CopyFromRecordset rsData
            Else
'###Modifica fatta da me per adattarlo da interbase
                'Avendo eseguito il controllo dei dati uso l'array
                For KK = 0 To nFieldsCount - 1
                  'invece di trasferire la matrice intera
                  'trasferisco colonna per colonna a seconda del tipo
                  Select Case VetTypeDB(KK)
                    Case adInteger, 131, 20 'Numero
                      For j = 1 To UBound(TempArray)
'###Usapunto è una mia funzione che mi restituisce un numero da virgola a
punto come separatore decimale.
                        TempArrayNUM(j, 1) = Val(UsaPunto(TempArray(j, KK +
1)))
                      Next j
                      .Range(ExcelCol(KK) & "2").Resize(rsData.RecordCount,
1).Value = TempArrayNUM
                    Case Else 'stringa o data
                      For j = 1 To UBound(TempArray)
                        TempArraySTR(j, 1) = TempArray(j, KK + 1)
                      Next j
                      .Range(ExcelCol(KK) & "2").Resize(rsData.RecordCount,
1).Value = TempArraySTR
                  End Select
                Next KK
'###Questa di seguito era l'istruzione che dava errore se TempArray era
definito com Variant
'###Definendolo As String non dava errore, ma gli importi e i numeric li
buttava come stringhe
'###Rendendo scomode le formattazioni manuali tipo col simbolo Euro ecc.
                '.Range("A2").Resize(rsData.RecordCount,
rsData.Fields.Count).Value = TempArray
            End If
            .Cells(2, 1).Activate
            .Columns.AutoFit
            .Name = sName
        End With
    End If
    WKS.SaveAs sPath
    'Chiusura degli oggetti aperti:
    'Disattivo la set nothing dell'oggetto recordset perchè
    ' la esegue la routine chiamante...
    'Set rsData = Nothing
    Set exclApp = Nothing
    Set WKS = Nothing
    Screen.MousePointer = 0
    Exit Sub
err:
    If err = 429 Then
        'Se Excel non è aperto
        err.Clear
        Set exclApp = CreateObject("Excel.Application")
        exclApp.Workbooks.Add
        Resume Resuming
    Else
        MsgBox Trim(str(err.Number)) & ":" & vbCrLf & err.Description,
vbOKOnly + vbCritical, "Errore"
    End If
    Screen.MousePointer = 0
End Sub
**************