1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117
| Function TransfertExcelAutomation()
Dim qd As QueryDef
Dim SQL As String
Dim val_export As Long
Dim xlApp As Excel.Application
Dim xlSheet As Excel.Worksheet
Dim xlBook As Excel.Workbook
Dim I As Long, J As Long
Dim t, l As Long
Dim Obj As OLEObject
Dim rec As Recordset
Dim exist As Recordset
Dim rec_next As Double
Dim nb_enre As Long
Dim RetVal As Variant
ExisteTable ("chgmt_cable") 'vérifie l'existance de la requête
SQL = "SELECT mes_champs FROM ma_requete "
Set qd = CurrentDb.CreateQueryDef("requete_tempo", SQL) 'Crée la requete temporaire
File_path = EnregistrerUnFichier(Me.hwnd, "Enregistrer fichier sous", "changement_liaison.xls", "C:\") ' permet d'enregistrer un nouveau fichier Excel et de mettre son chemin dans File_path
If File_path <> "" Then
DoCmd.OutputTo acOutputQuery, "requete_tempo", acSpreadsheetTypeExcel9, File_path, False 'L'ouvre sous excel
Set rec = CurrentDb.OpenRecordset("requete_tempo", dbOpenSnapshot)
'Initialisations
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(File_path)
'Ajouter une feuille de calcul
Set xlSheet = xlBook.Worksheets(1)
' les entetes
For J = 0 To rec.Fields.Count - 1
' Nous appliquons des enrichissements de format aux cellules
With xlSheet.Cells(1, J + 1)
.Interior.ColorIndex = 8
.Interior.Pattern = xlSolid
.Borders(xlEdgeBottom).LineStyle = xlContinuous
.Borders(xlEdgeBottom).Weight = xlThick
.Borders(xlEdgeBottom).ColorIndex = 3
.HorizontalAlignment = xlCenter
End With
Next J
'ERREUR ICI''''''''''''''''''''''''''''''''''''''''''''''''''''
xlBook.Activate
xlBook.Windows(1).SplitRow = 1
xlBook.Windows(1).FreezePanes = True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' recopie des données à partir de la ligne 3
I = 2
nb_enre = rec.RecordCount + 1
Do While Not (I = nb_enre)
If (rec_next <> Null Or rec(2) <> "Null") Then
rec.MoveNext
rec_next = rec(2).value
rec.MovePrevious
If (rec_next <> rec(2).value) Then
'For J = 0 To rec.Fields.Count - 1
xlSheet.Rows(I).Borders(xlEdgeBottom).Weight = xlThick
'Next J
End If
End If
xlSheet.Activate
xlSheet.Cells(I, 18).Select
t = ActiveCell.Top
l = ActiveCell.Left
If chk_budget.value = True Then
Set Obj = xlBook.ActiveSheet.OLEObjects.Add(ClassType:="Forms.CheckBox.1", Link:=False, _
DisplayAsIcon:=False, Left:=l + 30, Top:=t + 2, Width:=10, Height:=10) 'Créer une checkbox
Obj.name = "Check" & I
End If
I = I + 1
rec.MoveNext
Loop
' code de fermeture et libération des objets
'xlBook.Application.Visible = True
'xlBook.Save
xlApp.ActiveWorkbook.Save
xlApp.Application.Quit
RetVal = Shell("Taskkill /im Excel.exe /f", 0) 'Supprime toutes les tâches Excel
rec.Close
'Set rec = Nothing
Set xlSheet = Nothing
Set xlBook = Nothing
Set xlApp = Nothing
End If
Set qd = Nothing
DoCmd.DeleteObject acQuery, "requete_tempo" 'La supprime
End Function |
Partager