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
| Sub Utilisation()
If TestTable("T_RC") Then
DoCmd.Close acTable, "T_RC"
DoCmd.DeleteObject acTable, "T_RC"
End If
CurrentDb.Execute "SELECT RC.* INTO T_RC FROM RC;" ' crée la table "T_RC" à partir de la requête "RC"
ChangeLegendeChamp "T_RC"
End Sub
Sub ChangeLegendeChamp(strNomTable As String)
Dim Rs As DAO.Recordset
Dim I As Integer
Dim sChamp As String
Dim sLegende As String
Set Rs = CurrentDb.OpenRecordset(strNomTable)
With Rs
For I = 2 To .Fields.Count - 1
sChamp = .Fields(I).Name
sLegende = .Fields(I)
setCaption strNomTable, sChamp, sLegende
Next
.Delete ' supprime cette ligne, elle ne servait qu'à créer les légendes des champs.
.Close
End With
Set Rs = Nothing
End Sub
Public Sub setCaption(strNomTable, strNomChamp, strLegende)
Dim pr As DAO.Property
On Error GoTo err_setCaption
CurrentDb.TableDefs(strNomTable).Fields(strNomChamp).Properties("Caption").Value = strLegende
exit_setCaption:
Exit Sub
err_setCaption:
If Err.Number = 3270 Then
Set pr = CurrentDb.TableDefs(strNomTable).Fields(strNomChamp).CreateProperty("Caption", dbText, strLegende)
CurrentDb.TableDefs(strNomTable).Fields(strNomChamp).Properties.Append pr
Else
MsgBox Err.Number & ": " & Err.Description, vbCritical, "MyApp"
Resume exit_setCaption
End If
End Sub
Function TestTable(strNomTable As String) As Boolean
Const TABLETYPE = 1
If DLookup("Type", "MSysObjects", BuildCriteria("Type", dbInteger, TABLETYPE) & " AND " & BuildCriteria("Name", dbText, strNomTable)) = 1 Then
TestTable = True
Else
TestTable = False
End If
End Function |
Partager