cmq posto il codice
codice:
Su Progetto->Riferimenti devi selezionare Microsoft Excel 9.0 Object o 8.0
Private Sub cmdExport_Click()
On Error GoTo Err_Excel
Dim objXL As Excel.Application
Dim objWB As Excel.Workbook
Dim objWS As Excel.Worksheet
Dim tmprs As ADODB.Recordset
Dim n As Integer
Dim posizione As Integer
Dim StrSql As String
Screen.MousePointer = vbHourglass
Set objXL = New Excel.Application
Set objWB = objXL.Workbooks.Add
Set objWS = objWB.Worksheets(1)
Set tmprs = New ADODB.Recordset
n = 1
posizione = 1
objWS.Rows("1:1").Font.Bold = True
objWS.Cells(n, posizione).Value = "Pippo" 'Scrivo Pippo nella cella 1:1
posizione = posizione + 1
objWS.Cells(n, posizione).Value = "Pluto" 'Scrivo Pluto nella cella 1:2
posizione = posizione + 1
StrSql = "select ......." 'select su access dei dati che interessa
tmprs.Open StrSql, DB, adOpenKeyset, adLockOptimistic
If Not tmprs.EOF And Not tmprs.BOF Then
tmprs.MoveFirst
While Not tmprs.EOF
posizione = 1
n = n + 1
objWS.Cells(n, posizione).Value = tmprs!Nome_Campo
posizione = posizione + 1
objWS.Cells(n, posizione).Value = tmprs!Nome_Campo1
tmprs.MoveNext
Wend
Screen.MousePointer = vbDefault
objWS.Cells.EntireColumn.AutoFit
objWB.SaveAs "C:\Nome_File.xls"
objWB.Close
objXL.Quit
Set objWS = Nothing
Set objWB = Nothing
Set objXL = Nothing
MsgBox "Dati estratti con successo.", vbInformation
Else
MsgBox "Non ci sono dati da estrarre", vbInformation
End If
Exit Sub
Err_Excel:
Screen.MousePointer = vbDefault
MsgBox "Si è verificato un errore: " & Err.Description, vbCritical, "Errore"
Exit Sub
Resume 0
End Sub
Ciao
Permessi di invio
Rispondi quotando