Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Access Nouveau champ dans une table attachée

Nouveau champ dans une table attachée

2 réponses
Avatar
Fred
Bien compris Raymond.
Je peux sans problème récuperer le chemin de la base, mais pour la table
?...
A la place de Set MaBase = CurrentDb()
il faut que je rentre Set MaBase = "c:\mabase.mdb" ?

A priori, non. Il m'affiche "incompatible" ! Le vilain !
Je cherche toujours une solution pour ajouter un champ à une table
attachée... si quelqu'un a une idée...

Merci d'avance

Fred
Signaler un problème avec ce contenu

2 réponses

Supprimer
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire

Veuillez sélectionner un problème

Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
Avatar
André AVONS
Salut
'---------------------------------------------------------------------------
------------
' Procedure : AjoutChampDansTable
' DateTime : 18-06-2002 23:54
' Author : AVONS
' Purpose :
'---------------------------------------------------------------------------
------------
'Exemple :
AjoutChampDansTable("SuiviCourrier","Traite",dbboolean,false,"C:BaseDeDonne
es.mdb")

Function AjoutChampDansTable(table As String, Champ As String, TypeChamp As
Integer, _
NumAuto As Boolean, Optional NomBase As String, Optional ValDefT As String,
_
Optional FormatChamp As Integer, Optional LibelleChamp As String)
'Nombase chemin complet de la base
On Error GoTo AjoutChampDansTable_Error

Dim bds As Database, CheminBase As String
Dim tdf As TableDef, fld As Field, chp As Field
Dim wrkJet As Workspace

If IsNull(NomBase) Or IsEmpty(NomBase) Or NomBase = "" Then
CheminBase = CurrentDb.Name
Else
CheminBase = NomBase
End If

Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)
Set bds = wrkJet.OpenDatabase(CheminBase)

' Crée un nouvel objet TableDef.
Set tdf = bds.TableDefs(table)

'Creation du champ
Set fld = tdf.CreateField(Champ, TypeChamp)
'Creation du champ auto
If NumAuto And TypeChamp = dbLong Then
fld.OrdinalPosition = 1
fld.Attributes = dbAutoIncrField
End If
'Valeur par defaut texte
If IsNull(ValDefT) Or IsEmpty(ValDefT) Or ValDefT = "" Then
Else
fld.DefaultValue = ValDefT
End If

'activation du champ
tdf.Fields.Append fld

'Libelle Champ
If IsNull(LibelleChamp) Or IsEmpty(LibelleChamp) Or LibelleChamp = ""
Then
Else
Set chp = tdf.Fields(Champ)
Call DéfinirPropriété(chp, "Description", dbText, LibelleChamp)
End If

'Definition du format de champ
If FormatChamp > 0 Then
GoSub FormatDeChamp
End If


Fin:

bds.Close
wrkJet.Close
Set fld = Nothing
Set bds = Nothing
Set chp = Nothing
Set tdf = Nothing
Set wrkJet = Nothing

Exit Function

AjoutChampDansTable_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in procedure
AjoutChampDansTable of Module Ajout Champ dans Table"
Resume Fin
'========================================================================== ==== ' Création de propriétés pour certains champs
'utilise la fonction DéfinirPropriété du module DéfinirPropriétéAccess
'========================================================================== ==== FormatDeChamp:
Select Case FormatChamp
Case 1
'----------------------------------
'Case a cocher *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acCheckBox = Case à cocher (106)
'Propriété DisplayControl
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acCheckBox)
Call DéfinirPropriété(chp, "Format", dbText, "True/False")

Case 3
'----------------------------------
'Zone de texte *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acTextBox = Zone de texte
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acTextBox)

Case 3
'----------------------------------
'Zone de liste *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acListBox = Zone de liste
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acListBox)

Case 4
'----------------------------------
'Zone de liste Modifiable *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acComboBox = Zone de liste modifiable
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acComboBox)
Call DéfinirPropriété(chp, "RowSourceType", dbText, "Table/requête")
'"Table/requête", "Liste valeurs" ou "Liste champs"
Call DéfinirPropriété(chp, "RowSource", dbText, "CourrierNumerise")
Call DéfinirPropriété(chp, "ColumnCount ", dbText, "4")
'Call DéfinirPropriété(chp, "ColumnWidths", dbText, "")
Call DéfinirPropriété(chp, "ListWidth", dbText, "12")
Call DéfinirPropriété(chp, "LimitToList", dbBoolean, True)



End Select
Return


End Function
'=================================================== 'Call DéfinirPropriété(chp, "Format", dbText, "True/False") '"Yes/No" ou
'"True/False" ou "On/Off"

Function DéfinirPropriété(obj As Object, _
chNom As String, entType As Integer, _
varSetting As Variant) As Boolean
On Error GoTo ErrorDéfinirPropriétéAccess

Dim prp As Property
Const conPropNotFound As Integer = 3270 'Prop non définie.

' Se réfère explicitement à la collection properties.
obj.Properties(chNom) = varSetting
obj.Properties.Refresh
DéfinirPropriété = True

SortieDéfinirPropriétéAccess:
Exit Function

ErrorDéfinirPropriétéAccess:
If Err = conPropNotFound Then
' Crée une propriété, précise le type et définit une valeur
initiale.
Set prp = obj.CreateProperty(chNom, entType, varSetting)
' Ajoute l'objet Property à la collection Properties.
obj.Properties.Append prp
obj.Properties.Refresh
DéfinirPropriété = True
Resume SortieDéfinirPropriétéAccess
Else
MsgBox Err & ": " & Err.Number & vbCrLf & Err.Description
DéfinirPropriété = False
Resume SortieDéfinirPropriétéAccess
End If
End Function



--
@+
André

Quelques liens avec des exemples, des utilitaires et des compléments pour
Access
http://access.seneque.free.fr/
http://www.self-access.com/
http://www.mvps.org/accessfr/
http://mypage.bluewin.ch/w.stucki/
http://access.jessy.free.fr/

"Fred" a écrit dans le message de news:
bvdeit$8ki$
Bien compris Raymond.
Je peux sans problème récuperer le chemin de la base, mais pour la table
?...
A la place de Set MaBase = CurrentDb()
il faut que je rentre Set MaBase = "c:mabase.mdb" ?

A priori, non. Il m'affiche "incompatible" ! Le vilain !
Je cherche toujours une solution pour ajouter un champ à une table
attachée... si quelqu'un a une idée...

Merci d'avance

Fred





Avatar
Fred
Je bosse là dessus !
Merci mille fois André !

Fred
"André AVONS" a écrit dans le message de news:

Salut

'---------------------------------------------------------------------------

------------
' Procedure : AjoutChampDansTable
' DateTime : 18-06-2002 23:54
' Author : AVONS
' Purpose :

'---------------------------------------------------------------------------

------------
'Exemple :

AjoutChampDansTable("SuiviCourrier","Traite",dbboolean,false,"C:BaseDeDonne

es.mdb")

Function AjoutChampDansTable(table As String, Champ As String, TypeChamp
As

Integer, _
NumAuto As Boolean, Optional NomBase As String, Optional ValDefT As
String,

_
Optional FormatChamp As Integer, Optional LibelleChamp As String)
'Nombase chemin complet de la base
On Error GoTo AjoutChampDansTable_Error

Dim bds As Database, CheminBase As String
Dim tdf As TableDef, fld As Field, chp As Field
Dim wrkJet As Workspace

If IsNull(NomBase) Or IsEmpty(NomBase) Or NomBase = "" Then
CheminBase = CurrentDb.Name
Else
CheminBase = NomBase
End If

Set wrkJet = CreateWorkspace("", "admin", "", dbUseJet)
Set bds = wrkJet.OpenDatabase(CheminBase)

' Crée un nouvel objet TableDef.
Set tdf = bds.TableDefs(table)

'Creation du champ
Set fld = tdf.CreateField(Champ, TypeChamp)
'Creation du champ auto
If NumAuto And TypeChamp = dbLong Then
fld.OrdinalPosition = 1
fld.Attributes = dbAutoIncrField
End If
'Valeur par defaut texte
If IsNull(ValDefT) Or IsEmpty(ValDefT) Or ValDefT = "" Then
Else
fld.DefaultValue = ValDefT
End If

'activation du champ
tdf.Fields.Append fld

'Libelle Champ
If IsNull(LibelleChamp) Or IsEmpty(LibelleChamp) Or LibelleChamp = ""
Then
Else
Set chp = tdf.Fields(Champ)
Call DéfinirPropriété(chp, "Description", dbText, LibelleChamp)
End If

'Definition du format de champ
If FormatChamp > 0 Then
GoSub FormatDeChamp
End If


Fin:

bds.Close
wrkJet.Close
Set fld = Nothing
Set bds = Nothing
Set chp = Nothing
Set tdf = Nothing
Set wrkJet = Nothing

Exit Function

AjoutChampDansTable_Error:

MsgBox "Error " & Err.Number & " (" & Err.Description & ") in
procedure

AjoutChampDansTable of Module Ajout Champ dans Table"
Resume Fin

'========================================================================== > ==== > ' Création de propriétés pour certains champs

'utilise la fonction DéfinirPropriété du module DéfinirPropriétéAccess

'========================================================================== > ==== > FormatDeChamp:

Select Case FormatChamp
Case 1
'----------------------------------
'Case a cocher *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acCheckBox = Case à cocher (106)
'Propriété DisplayControl
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acCheckBox)
Call DéfinirPropriété(chp, "Format", dbText, "True/False")

Case 3
'----------------------------------
'Zone de texte *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acTextBox = Zone de texte
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acTextBox)

Case 3
'----------------------------------
'Zone de liste *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acListBox = Zone de liste
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acListBox)

Case 4
'----------------------------------
'Zone de liste Modifiable *
'----------------------------------
Set chp = tdf.Fields(Champ) 'acComboBox = Zone de liste modifiable
Call DéfinirPropriété(chp, "DisplayControl", dbInteger, acComboBox)
Call DéfinirPropriété(chp, "RowSourceType", dbText, "Table/requête")
'"Table/requête", "Liste valeurs" ou "Liste champs"
Call DéfinirPropriété(chp, "RowSource", dbText, "CourrierNumerise")
Call DéfinirPropriété(chp, "ColumnCount ", dbText, "4")
'Call DéfinirPropriété(chp, "ColumnWidths", dbText, "")
Call DéfinirPropriété(chp, "ListWidth", dbText, "12")
Call DéfinirPropriété(chp, "LimitToList", dbBoolean, True)



End Select
Return


End Function
'=================================================== > 'Call DéfinirPropriété(chp, "Format", dbText, "True/False") '"Yes/No" ou
'"True/False" ou "On/Off"

Function DéfinirPropriété(obj As Object, _
chNom As String, entType As Integer, _
varSetting As Variant) As Boolean
On Error GoTo ErrorDéfinirPropriétéAccess

Dim prp As Property
Const conPropNotFound As Integer = 3270 'Prop non définie.

' Se réfère explicitement à la collection properties.
obj.Properties(chNom) = varSetting
obj.Properties.Refresh
DéfinirPropriété = True

SortieDéfinirPropriétéAccess:
Exit Function

ErrorDéfinirPropriétéAccess:
If Err = conPropNotFound Then
' Crée une propriété, précise le type et définit une valeur
initiale.
Set prp = obj.CreateProperty(chNom, entType, varSetting)
' Ajoute l'objet Property à la collection Properties.
obj.Properties.Append prp
obj.Properties.Refresh
DéfinirPropriété = True
Resume SortieDéfinirPropriétéAccess
Else
MsgBox Err & ": " & Err.Number & vbCrLf & Err.Description
DéfinirPropriété = False
Resume SortieDéfinirPropriétéAccess
End If
End Function



--
@+
André

Quelques liens avec des exemples, des utilitaires et des compléments pour
Access
http://access.seneque.free.fr/
http://www.self-access.com/
http://www.mvps.org/accessfr/
http://mypage.bluewin.ch/w.stucki/
http://access.jessy.free.fr/

"Fred" a écrit dans le message de news:
bvdeit$8ki$
Bien compris Raymond.
Je peux sans problème récuperer le chemin de la base, mais pour la table
?...
A la place de Set MaBase = CurrentDb()
il faut que je rentre Set MaBase = "c:mabase.mdb" ?

A priori, non. Il m'affiche "incompatible" ! Le vilain !
Je cherche toujours une solution pour ajouter un champ à une table
attachée... si quelqu'un a une idée...

Merci d'avance

Fred