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
118
119
120
121
122
123
124
125
126
127
128
| Option Compare Database
Option Explicit
Private Sub Form_Open(Cancel As Integer)
Dim tbd As DAO.TableDef, qdf As DAO.QueryDef
' Alimenter la liste de ChoisissezTables
Me.ChoisissezTable.RowSource = ""
For Each tbd In CurrentDb.TableDefs
If Left(tbd.Name, 4) <> "MSys" And Left(tbd.Name, 1) <> "~" Then
' les tables système ne sont pas prises en charge
' ni les tables supprimées ~TMP
' ni les requêtes source des formulaires, états et zones de liste ~sq
' on aligne les noms de tables, séparés par ";" dans la source de la liste modifiable
Me.ChoisissezTable.RowSource = Me.ChoisissezTable.RowSource & tbd.Name & ";"
End If
Next
' idem pour les requêtes
For Each qdf In CurrentDb.QueryDefs
If Left(qdf.Name, 1) <> "~" And qdf.Name <> "rExportVersExcel" Then
Me.ChoisissezTable.RowSource = Me.ChoisissezTable.RowSource & qdf.Name & ";"
End If
Next
' dérouler la liste
Me.ChoisissezTable.SetFocus
Me.ChoisissezTable.Dropdown
End Sub
Private Sub ChoisissezTable_AfterUpdate()
Dim Db As DAO.Database, tbd As DAO.TableDef, fld As DAO.Field, qdf As DAO.QueryDef
'Réinitialiser la liste de droite
Me.lstDroite.RowSource = ""
'Aménager la liste des champs possibles dans lstGauche
Me.lstGauche.RowSource = ""
Set Db = CurrentDb
If EstCeUneTable(Me.ChoisissezTable) Then
Set tbd = Db.TableDefs(Me.ChoisissezTable)
'Créer la liste des colonnes
For Each fld In tbd.Fields
Me.lstGauche.RowSource = Me.lstGauche.RowSource & "[" & fld.Name & "];"
Next
Else
' c'est donc une requête
Set qdf = CurrentDb.QueryDefs(Me.ActiveControl)
'Créer la liste des colonnes
For Each fld In qdf.Fields
Me.lstGauche.RowSource = Me.lstGauche.RowSource & "[" & fld.Name & "];"
Next
End If
Set tbd = Nothing
Set qdf = Nothing
End Sub
Private Sub TransposerElement(lstSource As ListBox, lstDestination As ListBox, _
Optional LimiteSelection As Boolean = True)
Dim i As Integer
Dim strTemp As String
With lstSource
For i = 0 To .ListCount - 1
'si l'élement est sélectionné dans la liste source
If .Selected(i) Or Not LimiteSelection Then
lstDestination.RowSource = lstDestination.RowSource & .Column(0, i) & ";"
Else
'sinon, le conserve dans la liste source
strTemp = strTemp & .Column(0, i) & ";"
End If
Next i
'Affecte la nouvelle source à lstSource
.RowSource = strTemp
End With
End Sub
Private Sub BtExporter_Click()
On Error GoTo GestionErreurs
Dim sSql As String
Dim q As QueryDef
'Avertir qu'aucun champ n'a été sélectionné
If Me.lstDroite.RowSource = "" Then
MsgBox "Vous devez au moins choisir un champ !", vbCritical
Exit Sub
End If
'Construction du sql de la requête
sSql = Me.lstDroite.RowSource
'Remplacer les ";" par des "," et supprimer la dernière virgule
sSql = Replace(sSql, ";", ",")
sSql = Left(sSql, Len(sSql) - 1)
'Compléter le SQL
sSql = "Select " & sSql & " From [" & Me.ChoisissezTable & "];"
Debug.Print sSql
'Adapter la requête standard à exporter
Set q = CurrentDb.QueryDefs("rExportVersExcel")
q.sql = sSql
'Export vers FromAccess.xls
'Supprimer l'ancien
Kill CurrentProject.Path & "\FromAccess.xls"
DoCmd.TransferSpreadsheet acExport, , "rExportVersExcel", CurrentProject.Path & "\FromAccess.xls", False
Set q = Nothing
GestionErreurs:
Select Case Err.Number
Case 0 'pas d'erreur
Exit Sub
Case 53 'le fichier Excel n'existe pas encore
Resume Next
Case Else
MsgBox "Erreur dans BtExporter_Click N° " & Err.Number & " " & Err.Description
End Select
End Sub
'Copie les élements sélectionnés vers la liste de droite
Private Sub GaucheDroite_Click()
TransposerElement lstGauche, lstDroite
End Sub
'Copie tous les élements vers la liste de droite
Private Sub GaucheDroiteTous_Click()
TransposerElement lstGauche, lstDroite, False
End Sub
'Copie les élements sélectionnés vers la liste de gauche
Private Sub DroiteGauche_Click()
TransposerElement lstDroite, lstGauche
End Sub
'Copie tous les élements vers la liste de gauche
Private Sub DroiteGaucheTous_Click()
TransposerElement lstDroite, lstGauche, False
End Sub |
Répondre avec citation
Partager