VBA création d'un champ dans une table si non existant

Ceci, pourquoi pas...


'Exemple :
'AjoutChampDansTable("SuiviCourrier","Traite",dbboolean,false,"C:BaseDeDonnees.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) As
Long
'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
Public Function NoMaj() As Long
NoMaj = DLookup("[IntituléNumérique]", "Paramètres numériques1",
"[NoParamètre]@")
End Function

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337ab03$0$29189$ba620e4c@news.skynet.be...

Bonjour à tous,


J'essaye de pondre un code VBA qui crée un champ, dans une table
existante, s'il n'existe pas.

Si l'un d'entre vous pouvait me mettre sur la voie.

Merci d'avance.

Pat

Merci pour ce code qui semble impec. Malheureusement la table que je veux
modifier est liée. Comment faire pour la modifier de manière transparente.

Merci d'avance

Pat

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337ab03$0$29189$ba620e4c@news.skynet.be...

Bonjour à tous,


J'essaye de pondre un code VBA qui crée un champ, dans une table
existante, s'il n'existe pas.

Si l'un d'entre vous pouvait me mettre sur la voie.

Merci d'avance.

Pat

Ca tombe bien, cette procédure sert précisément à ajouter un champ dans une
autre base que la base courante. Donc pas de problème.

Fred

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337de1c$0$17493$ba620e4c@news.skynet.be...

Merci pour ce code qui semble impec. Malheureusement la table que je veux
modifier est liée. Comment faire pour la modifier de manière transparente.

Merci d'avance

Pat

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337ab03$0$29189$ba620e4c@news.skynet.be...

Bonjour à tous,


J'essaye de pondre un code VBA qui crée un champ, dans une table
existante, s'il n'existe pas.

Si l'un d'entre vous pouvait me mettre sur la voie.

Merci d'avance.

Pat

Merci Fred, mais je sèche et j'ai de plus en plus mal au yeux (48 ans et la
presbytie arrive), de plus je n'ai plus programmé depuis + d'un an.

J'arrive pas à paramétrer le code que tu m'as fais parvenir.

En sachant que ma base est liée et à comme emplacement "C:/mabase.mdb"
Que la table à laquelle je souhaite rajouter les 2 champs se nomme "Client"
Que les champs à rajouter sont au format texte et se nomment
"CpteFinancier1" et "TitulaireCpteFinancier1"

Que faut-il modifier à ton code.

Merci et si j'abuse j'essayerai encore demain quand les yeux seront reposés
;-))

Pat


"Fred" <fred@memorys.fr> a écrit dans le message de news:
4337e302$0$23811$626a14ce@news.free.fr...

Ca tombe bien, cette procédure sert précisément à ajouter un champ dans
une autre base que la base courante. Donc pas de problème.

Fred

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337de1c$0$17493$ba620e4c@news.skynet.be...

Merci pour ce code qui semble impec. Malheureusement la table que je veux
modifier est liée. Comment faire pour la modifier de manière
transparente.

Merci d'avance

Pat

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337ab03$0$29189$ba620e4c@news.skynet.be...

Bonjour à tous,


J'essaye de pondre un code VBA qui crée un champ, dans une table
existante, s'il n'existe pas.

Si l'un d'entre vous pouvait me mettre sur la voie.

Merci d'avance.

Pat

Bonjour,


Je ne parviens toujours pas à faire fonctionner ce code pour rajouter deux
champs dans une table liée.

- En sachant que ma base liée, contenant les données, à comme emplacement
"C:/Appli/db.mdb"
- Que la base frontale à comme emplacement C:/Appli/Gestdb.mde
- Que la table à laquelle je souhaite rajouter les 2 champs se nomme
"Client"
- Que les champs à rajouter sont au format texte et se nomment
"CpteFinancier1" et "TitulaireCpteFinancier1"

Lorsque le lance le code avec une macro j'ai le message "Impossible de
trouver le nom table entré dans l'expression............"

Merci d'avance pour votre temps.

Pat

Ci-dessous le code que j'ai rentré entre les -----------------------------

----------------------------
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) As
Long

'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("Client")

'Creation du champ
Set fld = tdf.CreateField("CpteFinancier1", dbText, 20)
Set fld = tdf.CreateField("TitulaireCpteFinancier1", dbText, 60)
'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

End Function

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
Public Function NoMaj() As Long
NoMaj = DLookup("[IntituléNumérique]", "Paramètres numériques1",
"[NoParamètre]@")
End Function

----------------------------------------

"Pat" <nospam@nospam.net> a écrit dans le message de news:
43380968$0$16016$ba620e4c@news.skynet.be...

Merci Fred, mais je sèche et j'ai de plus en plus mal au yeux (48 ans et
la presbytie arrive), de plus je n'ai plus programmé depuis + d'un an.

J'arrive pas à paramétrer le code que tu m'as fais parvenir.

En sachant que ma base est liée et à comme emplacement "C:/mabase.mdb"
Que la table à laquelle je souhaite rajouter les 2 champs se nomme
"Client"
Que les champs à rajouter sont au format texte et se nomment
"CpteFinancier1" et "TitulaireCpteFinancier1"

Que faut-il modifier à ton code.

Merci et si j'abuse j'essayerai encore demain quand les yeux seront
reposés ;-))

Pat


"Fred" <fred@memorys.fr> a écrit dans le message de news:
4337e302$0$23811$626a14ce@news.free.fr...

Ca tombe bien, cette procédure sert précisément à ajouter un champ dans
une autre base que la base courante. Donc pas de problème.

Fred

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337de1c$0$17493$ba620e4c@news.skynet.be...

Merci pour ce code qui semble impec. Malheureusement la table que je
veux
modifier est liée. Comment faire pour la modifier de manière
transparente.

Merci d'avance

Pat

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337ab03$0$29189$ba620e4c@news.skynet.be...

Bonjour à tous,


J'essaye de pondre un code VBA qui crée un champ, dans une table
existante, s'il n'existe pas.

Si l'un d'entre vous pouvait me mettre sur la voie.

Merci d'avance.

Pat

Bonjour,


Je n'ai toujours pas trouvé de solution pour ajouter des champs à une table
liée.

Avec le code ci-dessus pas de problème de compilation mais je ne parviens
pas à l'exécuter ni avec une macro, ni à l'ouverture d'un formulaire (End
sub attendu)

Si quelqu'un à une idée? Merci d'avance.

Pat

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4338f3f9$0$19217$ba620e4c@news.skynet.be...

Bonjour,


Je ne parviens toujours pas à faire fonctionner ce code pour rajouter deux
champs dans une table liée.

- En sachant que ma base liée, contenant les données, à comme emplacement
"C:/Appli/db.mdb"
- Que la base frontale à comme emplacement C:/Appli/Gestdb.mde
- Que la table à laquelle je souhaite rajouter les 2 champs se nomme
"Client"
- Que les champs à rajouter sont au format texte et se nomment
"CpteFinancier1" et "TitulaireCpteFinancier1"

Lorsque le lance le code avec une macro j'ai le message "Impossible de
trouver le nom table entré dans l'expression............"

Merci d'avance pour votre temps.

Pat

Ci-dessous le code que j'ai rentré entre
es -----------------------------

----------------------------
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) As Long

'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("Client")

'Creation du champ
Set fld = tdf.CreateField("CpteFinancier1", dbText, 20)
Set fld = tdf.CreateField("TitulaireCpteFinancier1", dbText, 60)
'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

End Function

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
Public Function NoMaj() As Long
NoMaj = DLookup("[IntituléNumérique]", "Paramètres numériques1",
"[NoParamètre]@")
End Function

----------------------------------------

"Pat" <nospam@nospam.net> a écrit dans le message de news:
43380968$0$16016$ba620e4c@news.skynet.be...

Merci Fred, mais je sèche et j'ai de plus en plus mal au yeux (48 ans et
la presbytie arrive), de plus je n'ai plus programmé depuis + d'un an.

J'arrive pas à paramétrer le code que tu m'as fais parvenir.

En sachant que ma base est liée et à comme emplacement "C:/mabase.mdb"
Que la table à laquelle je souhaite rajouter les 2 champs se nomme
"Client"
Que les champs à rajouter sont au format texte et se nomment
"CpteFinancier1" et "TitulaireCpteFinancier1"

Que faut-il modifier à ton code.

Merci et si j'abuse j'essayerai encore demain quand les yeux seront
reposés ;-))

Pat


"Fred" <fred@memorys.fr> a écrit dans le message de news:
4337e302$0$23811$626a14ce@news.free.fr...

Ca tombe bien, cette procédure sert précisément à ajouter un champ dans
une autre base que la base courante. Donc pas de problème.

Fred

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337de1c$0$17493$ba620e4c@news.skynet.be...

Merci pour ce code qui semble impec. Malheureusement la table que je
veux
modifier est liée. Comment faire pour la modifier de manière
transparente.

Merci d'avance

Pat

"Pat" <nospam@nospam.net> a écrit dans le message de news:
4337ab03$0$29189$ba620e4c@news.skynet.be...

Bonjour à tous,


J'essaye de pondre un code VBA qui crée un champ, dans une table
existante, s'il n'existe pas.

Si l'un d'entre vous pouvait me mettre sur la voie.

Merci d'avance.

Pat