Besoin d'aide approfondissement script

Version imprimable

Bonjour,

Je possède un script permettant d'ajouter rapidement des utilisateurs, référencés dans un fichier, dans un serveur. J'ai pu donc faire le script avec mes bases, et en me renseignant par-ci, par-là. Cependant n'étant pas spécialiste du VBScript, j'aimerais approfondir ce script afin le rendre le plus complet et efficace possible en 3 points :
~~- Remplacer tous les accents par les lettres sans accents~~
~~- En cas d'homonyme (ex : François BERTRAND et Frédéric BERTRAND etc...), ajouter un 2, 3... à l'identifiant de connexion~~
- Le cas où l'utilisateur se retrouve dans plusieurs Unités d'Organisation.

Pouvez-vous m'aider s.v.p ? Je vous présente mon code :
Code:

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 Do Until objFile.AtEndofStream Strline=objFile.ReadLine temp = split(Strline," ", 2) Dim Nom 'as String Dim Prenom 'as String if StrComp(temp(0), Ucase(temp(0))) = 0 Then Nom = temp(0) Prenom= temp(1) else Nom= temp(1) Prenom= temp(0) End If osn=Nom oGivenName=Prenom oUname = Left(oGivenName,1) & "." & osn
Merci d'avance !

Salut, Patrick_R, bienvenue sur DVP

Citation:

Remplacer tous les accents par les lettres sans accents

Pour cette partie, une fonction de conversion lettres accentuées vers lettres non accentuées

Code:

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
Function RegReplace(Text)
Dim RegularExpressioN, T, U
Dim TblReg, TblSubsit
Dim ListPattern, listSubsit
'création du tableau Pattern
              ListPattern = "À|Á|Â|Ã|Ä|Å Ç È|É|Ê|Ë Ì|Í|Î|Ï Ñ Ò|Ó|Ô|Õ|Ö Ù|Ú|Û|Ü Ý|Ÿ Ž"
ListPattern = ListPattern & " š à|á|â|ã|ä|å ç è|é|ê|ë ì|í|î|ï ñ ð|ò|ó|ô|õ|ö ù|ú|û|ü ý|ÿ"
TblReg = Split(ListPattern, " ", -1, vbTextCompare)
'création du tableau de substitution des lettres accentuées en lettre non accentuée
listSubsit = "A C E I N O U Y Z s a c e i n o u y"
TblSubsit = Split(listSubsit, " ", -1, vbTextCompare)
 
T = UBound(TblReg) - 1
Set RegularExpressioN = New RegExp
RegularExpressioN.Global = True
RegReplace = Text
For U = 0 To T
    RegularExpressioN.Pattern = TblReg(U)
    RegReplace = RegularExpressioN.Replace(RegReplace, TblSubsit(U))   ' Effectue le remplacement
Next
 
Set RegularExpressioN = Nothing
End Function
 
'2 exemples d'utilisation
MsgBox RegReplace("Je possède un script permettant d'ajouter rapidement des utilisateurs, référencés dans un fichier")
MsgBox RegReplace("en me renseignant par-ci, par-là. Cependant n'étant pas spécialiste du VBScript")

22/04/2017, 11h51
Patrick_R

C'est parfait ! Merci beaucoup pour cette aide ! Cela fonctionne.

Avec cette fonction, est-il possible également de remplacer les ', - ... par rien du tout ? Par exemple : A'B → AB et C-D → CD ?
22/04/2017, 12h20
ProgElecT
Re

Oui en ajoutant ces 2 lignes entre Next et Set RegularExpressioN = Nothing
Code:

1 2 RegularExpressioN.Pattern = "-|'" RegReplace = RegularExpressioN.Replace(RegReplace, "")
Par contre, avec les 2 exemples proposés, cela n'est pas top :?
22/04/2017, 14h01
Patrick_R
Citation:
Envoyé par ProgElecT

Re

Oui en ajoutant ces 2 lignes entre Next et Set RegularExpressioN = Nothing

Code:

1 2 RegularExpressioN.Pattern = "-|'" RegReplace = RegularExpressioN.Replace(RegReplace, "")

Par contre, avec les 2 exemples proposés, cela n'est pas top :?
Super, merci beaucoup ! Il me reste désormais 2 éléments à approfondir :)

......

Franchement, je séparerais la fonction suppression des accents de ton autre demande (j'ai modifier le nom de la fonction de RegReplace en SuppAccents.

Code:

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
Function SuppAccents(Text)
Dim RegularExpressioN, T, U
Dim TblReg, TblSubsit
Dim ListPattern, listSubsit
'création du tableau Pattern
              ListPattern = "À|Á|Â|Ã|Ä|Å Ç È|É|Ê|Ë Ì|Í|Î|Ï Ñ Ò|Ó|Ô|Õ|Ö Ù|Ú|Û|Ü Ý|Ÿ Ž"
ListPattern = ListPattern & " š à|á|â|ã|ä|å ç è|é|ê|ë ì|í|î|ï ñ ð|ò|ó|ô|õ|ö ù|ú|û|ü ý|ÿ"
TblReg = Split(ListPattern, " ", -1, vbTextCompare)
'création du tableau de substitution des lettres accentuées en lettre non accentuée
listSubsit = "A C E I N O U Y Z s a c e i n o u y"
TblSubsit = Split(listSubsit, " ", -1, vbTextCompare)
 
T = UBound(TblReg) - 1
Set RegularExpressioN = New RegExp
RegularExpressioN.Global = True
SuppAccents = Text
For U = 0 To T
    RegularExpressioN.Pattern = TblReg(U)
    SuppAccents = RegularExpressioN.Replace(SuppAccents, TblSubsit(U))   ' Effectue le remplacement
Next
 
Set RegularExpressioN = Nothing
End Function
 
'2 exemples d'utilisation
dim TextSoumis, TextRetour
 
TextSoumis = "Je possède un script permettant d'ajouter rapidement des utilisateurs, référencés dans un fichier"
TextRetour = SuppAccents(TextSoumis)
MsgBox "Texte soumis:" & vbnewline & TextSoumis & vbnewline & vbnewline _
     & "Texte en retour:" & vbnewline & TextRetour, vbinformations,"sans accents"
 
 
TextSoumis = "en me renseignant par-ci, par-là. Cependant n'étant pas spécialiste du VBScript"
TextRetour = SuppAccents(TextSoumis)
'******** ici la supressions en 2 étapes des tirets et apostrophes avec la fonction native Replace ***********
TextRetour = Replace(TextRetour,"-","")
TextRetour = Replace(TextRetour,"'","")
MsgBox "Texte soumis:" & vbnewline & TextSoumis & vbnewline & vbnewline _
     & "Texte en retour:" & vbnewline & TextRetour, vbinformations,"sans accents ni tirets et apostrophes"

22/04/2017, 14h49
Patrick_R

D'accord, merci du conseil.

Citation:

En cas d'homonyme (ex : François BERTRAND et Frédéric BERTRAND etc...), ajouter un 2, 3... à l'identifiant de connexion

Je te propose ce

Code:

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
Dim DicO
 
Function NomIndexer(NomAIndex)
Dim Nindex, NomConstruit
Nindex = 2
Do
    NomConstruit = NomAIndex & "(" & Nindex & ")"
    If DicO.Exists(NomConstruit) = False Then NomIndexer = NomConstruit: Exit Do
    'NomConstruit existant déjà, incrémente le N° index
    Nindex = Nindex + 1
Loop
End Function
 
'-------------------------------------------------------------------------------
Dim SimulTonFichier
Dim T, U
Dim Strline, temp, Nom, Prenom
 
SimulTonFichier = "BERTRAND François" & vbNewLine _
                & "BERNARDO Françis" & vbNewLine _
                & "BERTRAND Frédéric" & vbNewLine _
                & "BERTRAND Luc" & vbNewLine _
                & "BERNARDO Jean" & vbNewLine _
                & "LAMENAS Max" & vbNewLine _
                & "DURANT Eric" & vbNewLine _
                & "LAMENAS Julien" & vbNewLine _
                & "BERTRAND Françoise"
 
Strline = Split(SimulTonFichier, vbNewLine) 'lecture 1er ligne
temp = Split(Strline(0), " ", 2): Nom = temp(0): Prenom = temp(1)
 
Set DicO = CreateObject("Scripting.Dictionary") ' création du tableau type Dictionary
DicO.Add Nom, Prenom '1er ajout du nom et prénom au tableau Dictionary
 
For T = 1 To UBound(Strline) ' équivalence te ta boucle Do Until objFile.AtEndofStream
    temp = Split(Strline(T), " ", 2)
    Nom = temp(0)
    Prenom = temp(1)
    If DicO.Exists(Nom) Then 'un même nom existe déjà dans le tableau Dictionary
        ' appel de la fonction pour indexer le nom
        Nom = NomIndexer(Nom)
    End If
    DicO.Add Nom, Prenom ' ajout du dernier nom/prénom, le nom a peut être été indexé
Next
 
 
'pour vérification
Dim LesNoms, LesPrenoms, MsG
LesNoms = DicO.keys ' récupération des noms
LesPrenoms = DicO.Items ' récupération des prénoms
U = DicO.Count 'Retourne le nombre de paires clés - éléments
For T = 0 To U - 1
    MsG = MsG & LesNoms(T) & " " & LesPrenoms(T) & vbNewLine
Next
MsgBox MsG
 
 
Set DicO = Nothing ' libération explicite de la mémoire

Il va falloir adapter, mais vue que tu as déjà compris la première solution au sujet des accents, je te fais confiance :P

22/04/2017, 18h13
Patrick_R
Cela fonctionne les Nom et Prenom. Cependant je veux que mes utilisateurs puissent se connecter avec la première lettre du prénom. NOM (Ex : François BERTRAND aura F.BERTRAND ; et Frank BERTRAND aura F.BERTRAND2 etc...)

Pour cela, j'ai
Code:

1 2 3 osn = SupprAccents(Nom) oGivenName=SupprAccents(Prenom) oUname = Left(oGivenName,1) & "." & osn
Je veux donc que mes utilisateurs soit affichés, mais seulement en cas d'homonyme identifiant, des chiffres s'y ajoutent.

.....
Remplacer la ligne 7 par NomConstruit = NomAIndex & Nindex et la ligne 53 par MsG = MsG & left(LesPrenoms(T),1) & "." & LesNoms(T) & vbNewLine.
Donc cela devrait ressembler à ce

Code:

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
Function NomIndexer(NomAIndex)
Dim Nindex, NomConstruit
Nindex = 2
Do
    NomConstruit = NomAIndex & Nindex
    If DicO.Exists(NomConstruit) = False Then NomIndexer = NomConstruit: Exit Do
    'NomConstruit existant déjà, incrémente le N° index
    Nindex = Nindex + 1
Loop
End Function
 
'-------------------------------------------------------------------------------
Dim SimulTonFichier
Dim T, U
Dim Strline, temp, Nom, Prenom
 
SimulTonFichier = "BERTRAND François" & vbNewLine _
                & "BERNARDO Françis" & vbNewLine _
                & "BERTRAND Frédéric" & vbNewLine _
                & "BERTRAND Luc" & vbNewLine _
                & "BERNARDO Jean" & vbNewLine _
                & "LAMENAS Max" & vbNewLine _
                & "DURANT Eric" & vbNewLine _
                & "LAMENAS Julien" & vbNewLine _
                & "BERTRAND Françoise"
 
Strline = Split(SimulTonFichier, vbNewLine) 'lecture 1er ligne
temp = Split(Strline(0), " ", 2): Nom = temp(0): Prenom = temp(1)
 
Set DicO = CreateObject("Scripting.Dictionary") ' création du tableau type Dictionary
DicO.Add Nom, Prenom '1er ajout du nom et prénom au tableau Dictionary
 
'*********** 1er étape ******************
For T = 1 To UBound(Strline) ' équivalence te ta boucle Do Until objFile.AtEndofStream
    temp = Split(Strline(T), " ", 2)
    Nom = temp(0)
    Prenom = temp(1)
    If DicO.Exists(Nom) Then 'un même nom existe déjà dans le tableau Dictionary
        ' appel de la fonction pour indexer le nom
        Nom = NomIndexer(Nom)
    End If
    DicO.Add Nom, Prenom ' ajout du dernier nom/prénom, le nom a peut être été indexé
Next
' fin de ta boucle Do
 
'************* 2ém étape *****************
Dim LesNoms, LesPrenoms
LesNoms = DicO.keys ' récupération des noms
LesPrenoms = DicO.Items ' récupération des prénoms
U = DicO.Count 'Retourne le nombre de paires clés - éléments
Set DicO = Nothing ' libération explicite de la mémoire
'inscription
For T = 0 To U - 1
    osn = SupprAccents(LesNoms(T))
    oGivenName=left(LesPrenoms(T),1)
    oUname = oGivenName & "." & osn
    'ligne(s) suivante(s) pour ajouter les utilisateurs
Next

Citation:

Envoyé par ProgElecT

.....
Remplacer la ligne 7 par NomConstruit = NomAIndex & Nindex et la ligne 53 par MsG = MsG & left(LesPrenoms(T),1) & "." & LesNoms(T) & vbNewLine.
Donc cela devrait ressembler à ce

Code:

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
Function NomIndexer(NomAIndex)
Dim Nindex, NomConstruit
Nindex = 2
Do
    NomConstruit = NomAIndex & Nindex
    If DicO.Exists(NomConstruit) = False Then NomIndexer = NomConstruit: Exit Do
    'NomConstruit existant déjà, incrémente le N° index
    Nindex = Nindex + 1
Loop
End Function
 
'-------------------------------------------------------------------------------
Dim SimulTonFichier
Dim T, U
Dim Strline, temp, Nom, Prenom
 
SimulTonFichier = "BERTRAND François" & vbNewLine _
                & "BERNARDO Françis" & vbNewLine _
                & "BERTRAND Frédéric" & vbNewLine _
                & "BERTRAND Luc" & vbNewLine _
                & "BERNARDO Jean" & vbNewLine _
                & "LAMENAS Max" & vbNewLine _
                & "DURANT Eric" & vbNewLine _
                & "LAMENAS Julien" & vbNewLine _
                & "BERTRAND Françoise"
 
Strline = Split(SimulTonFichier, vbNewLine) 'lecture 1er ligne
temp = Split(Strline(0), " ", 2): Nom = temp(0): Prenom = temp(1)
 
Set DicO = CreateObject("Scripting.Dictionary") ' création du tableau type Dictionary
DicO.Add Nom, Prenom '1er ajout du nom et prénom au tableau Dictionary
 
'*********** 1er étape ******************
For T = 1 To UBound(Strline) ' équivalence te ta boucle Do Until objFile.AtEndofStream
    temp = Split(Strline(T), " ", 2)
    Nom = temp(0)
    Prenom = temp(1)
    If DicO.Exists(Nom) Then 'un même nom existe déjà dans le tableau Dictionary
        ' appel de la fonction pour indexer le nom
        Nom = NomIndexer(Nom)
    End If
    DicO.Add Nom, Prenom ' ajout du dernier nom/prénom, le nom a peut être été indexé
Next
' fin de ta boucle Do
 
'************* 2ém étape *****************
Dim LesNoms, LesPrenoms
LesNoms = DicO.keys ' récupération des noms
LesPrenoms = DicO.Items ' récupération des prénoms
U = DicO.Count 'Retourne le nombre de paires clés - éléments
Set DicO = Nothing ' libération explicite de la mémoire
'inscription
For T = 0 To U - 1
    osn = SupprAccents(LesNoms(T))
    oGivenName=left(LesPrenoms(T),1)
    oUname = oGivenName & "." & osn
    'ligne(s) suivante(s) pour ajouter les utilisateurs
Next

Le script devient un vrai bazar :mouarf:. J'étudierai ce code demain, merci beaucoup !

Bonsoir,

Concernant la réponse d'en haut, j'ai fini. Merci beaucoup Prog

J'ai une question, avec ce code
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 if StrComp(temp(0), Ucase(temp(0))) = 0 Then 'Compare les 2 mots séparés : Le mot en majuscule va dans Nom Nom = temp(0) Prenom= temp(1) else Nom= temp(1) Prenom= temp(0) End If osn=Nom oGivenName=Prenom oUname = Left(oGivenName,1) & "." & osn
Comment faire pour que par exemple avec Jean-François NOM, l'identifiant soit JF.NOM et pas J.NOM ?

Merci.

Salut

Une solution parmi d'autres

Code:

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
'******************* Ma façon de faire *****************
Private Function FormatPrenom(Mot As String) As String
Dim Tbl() As String, T As Integer
Mot = Replace(Mot, " ", "-")
Tbl = Split(Mot, "-")
If UBound(Tbl) >= 1 Then
    For T = 0 To UBound(Tbl)
        FormatPrenom = FormatPrenom & Left(Tbl(T), 1)
    Next T
    Else
    FormatPrenom = Left(Mot, 1)
End If
End Function
 
Private Sub Command1_Click()
Dim temp(1) As String, Nom As String, Prenom As String, osn As String, oGivenName As String, oUname As String
'pour différant cas de figures
'temp(0) = "François"
'temp(0) = "Jean-François"
'temp(0) = "Jean François"
temp(0) = "Pierres Jean-François"
 
temp(1) = "LENOM"
 
If StrComp(temp(0), UCase(temp(0))) = 0 Then 'Compare les 2 mots séparés : Le mot en majuscule va dans Nom
    Nom = temp(0)
    Prenom = temp(1)
    Else
    Nom = temp(1)
    Prenom = temp(0)
End If
 
osn = Nom
oGivenName = FormatPrenom(Prenom)
'oGivenName = Prenom
 
oUname = oGivenName & "." & osn
Label1.Caption = oUname
End Sub

06/05/2017, 18h41
Patrick_R
Bonjour,

Comment faire pour ignorer une (plusieurs) ligne(s) vide(s) du fichier ?
J'ai essayé avec :
Code:

1 2 3 4 [...] Do Until objFile.AtEndofStream If Len(Trim(StrLine)) > 0 Then
Mais cela ne fonctionne pas.

Salut

Code:

1
2
3
4
5
6
7
8
Do Until objFile.AtEndofStream
    Strline = objFile.ReadLine
    If Trim(Strline) <> "" Then
        MsgBox "la ligne contient bien une information"
        Else
        MsgBox "la ligne est vide"
    End If
Loop

06/05/2017, 19h50
Patrick_R

Comme avec "Len(Trim etc...)", cela indique que l'objet existe déja en s'arrêtant à la ligne vide (et en ayant ajouté ce qui n'est pas vide) :?

Vite fait

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
Const ForReading = 1, ForWriting = 2
Dim oFso, objFile, Strline
    Set oFso = CreateObject("Scripting.FileSystemObject")
  Set objFile = oFso.OpenTextFile("C:\PersoFrancis\regsvr32UtilisationDe.txt", ForReading)
Do Until objFile.AtEndofStream
    Strline = objFile.ReadLine
    If Trim(Strline) <> "" Then
        MsgBox "la ligne contient bien une information" & vbnewline & Strline
        Else
        MsgBox "la ligne est vide"
    End If
Loop
objFile.Close