Bonjour,
j'ai fais une fonction qui va chercher les elements d'une table pour les copier dans un fichier excel.
Ca marche mais c'est tres lent.
Peut etre pourriez vous me dire comment alleger moncode ...
Public Function Export_In_Excel_File(ByVal Conn As ADODB.Connection, ByVal ID As String, ByVal Query As String, ByVal sFile As String, ByVal sFormat As Excel.XlFormatFilterTypes) As Boolean
Dim RsExcel As ADODB.Recordset
Dim NbFields As Integer
Dim CurSheet As Integer
Dim a As Integer
Dim b As Integer
b = 0
Export_In_Excel_File = False 'to indicate that the record isn't successful
On Error GoTo ErrorExportInExcelFile
Dim appExcel As Excel.Application
NbField = 0
Set RsExcel = Conn.OpenSchema(adSchemaColumns)
Set appExcel = CreateObject("Excel.Application") 'create the application and open Excel
appExcel.Workbooks.add 'new file
CurSheet = 1
appExcel.Sheets(CurSheet).Select
appExcel.DisplayAlerts = False 'hide alert from Excel
For a = 1 To appExcel.Sheets.Count - 1 'delete all sheet except one
appExcel.Sheets(1).Select
appExcel.ActiveWindow.SelectedSheets.Delete
Next a
appExcel.ActiveSheet.Name = "ID" & ID & " (" & CurSheet & ")" 'the name of the sheet
With appExcel
.Rows("1:1").Select 'select the first line
.Selection.Font.Bold = True 'first line : BOLD
.Columns("B:B").ColumnWidth = 13 'adapt the width of the IP Column
.Columns("C:C").ColumnWidth = 17 'adapt the width of the DateTime Column
.Cells.Select 'select all cells
End With
appExcel.Selection.HorizontalAlignment = xlCenter
appExcel.Range("A1").Select 'select the first cell
Do Until RsExcel.EOF 'write the title of each column
If RsExcel.Fields("TABLE_NAME") = ID Then
NbField = NbField + 1
appExcel.ActiveCell.Value = RsExcel.Fields("COLUMN_NAME")
appExcel.ActiveCell.Next.Select
End If
RsExcel.MoveNext
Loop
Set RsExcel = New ADODB.Recordset
RsExcel.Open Query, Conn, adOpenDynamic, adLockPessimistic
Do While RsExcel.EOF = False 'fill all cells
If appExcel.ActiveCell.Row < 65535 Then 'if this is not the end of the sheet
appExcel.ActiveCell.Offset(1, -NbField).Activate 'return at the beginning of the next row
Else
appExcel.ActiveWindow.SelectedSheets.add After:=appExcel.Sheets(CurSheet) 'create a new sheet
CurSheet = CurSheet + 1
appExcel.Sheets(CurSheet).Select
appExcel.ActiveSheet.Name = "ID" & ID & " (" & CurSheet & ")" 'the name of the sheet
With appExcel.ActiveSheet
.Columns("B:B").ColumnWidth = 13 'adapt the width of the IP Column
.Columns("C:C").ColumnWidth = 17 'adapt the width of the DateTime Column
.Cells.Select 'select all cells
End With
appExcel.Selection.HorizontalAlignment = xlCenter
End If
For a = 0 To NbField - 1
appExcel.ActiveCell.Value = RsExcel.Fields(a).Value
appExcel.ActiveCell.Next.Select 'select the next cell
Next a
RsExcel.MoveNext
b = b + 1
If b > 19 Then
DoEvents 'stop the prosse if the computer need to do something
b = 0
End If
Loop
RsExcel.Close
Set RsExcel = Nothing
appExcel.ActiveWorkbook.SaveAs FileName:=sFile, FileFormat:=sFormat, Password:="", _
WriteResPassword:="", ReadOnlyRecommended:=False, _
CreateBackup:=False 'save the file
appExcel.ActiveWorkbook.Close 'close the file
appExcel.Quit 'close Excel
Set appExcel = Nothing
Export_In_Excel_File = True 'to indicate that the record is successfull
On Error GoTo 0
Exit Function
ErrorExportInExcelFile:
On Error Resume Next
Set RsExcel = Nothing
Set appExcel = Nothing
On Error GoTo 0
End Function
Merci d'avance.
Et sinon comment puis je faire pour afficher une barre de progression. Mais une toute simple, il n'y a pas un controle que je puisse utiliser ?
Il faudrais une barre du genre celle qui apparait au demerrage de XP : qui tourne en boucle, car je ne peux pas savoir le pourcentage d'avancement ....
Merci pour votre aide.