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 |
Partager