Texte PREMLETTRE

[Staple1600]

Bonjour,

Une fonction utilisable dans l'univers Windows uniquement

Function PREMLETTRE(S$) As String
Dim mc As Object, m As Object
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = "\b\w"
    If .test(S) = True Then
        Set mc = .Execute(S)
        For Each m In mc
            PREMLETTRE = UCase(PREMLETTRE & m) & "."
            Next m
        End If
End With
End Function

Exemple d'usage
En A1: darkside of the moon
en B1 =PREMLETTRE(A1) renvoie D. S. O. T. M.

Ci dessous une variante avec choix de la casse

Function PREMLETTRE(S$, Optional casse As VbStrConv) As String
Dim mc As Object, m As Object
With CreateObject("vbscript.regexp")
    .Global = True
    .Pattern = "\b\w"
    If .test(S) = True Then
        Set mc = .Execute(S)
        For Each m In mc
            PREMLETTRE = StrConv(PREMLETTRE & m, casse) & "."
            Next m
        End If
End With
End Function

Avec comme paramétres : 1, 2 ou 3
=PREMLETTRE(A1;1) -< MAJUSCULE
=PREMLETTRE(A1;2) -< minuscule
=PREMLETTRE(A1;3) -< Nom propre

 

[patricktoulon]

re
Staple1600
PLTR??????????(remplacé par "PREMLETTRE"

il manque le "S" chez moi

 

[Staple1600]

Bonjour patricktoulon

Erreur de copier/coller
J'ai corrigé dans le message initial

Chez moi, j'ai bien le S avec les deux fonctions.

 

[Magic_Doctor]

Bonjour,

Personnellement, j'aurais intitulé cette fonction "Acronyme".
Cette fonction, telle qu'elle est, marche bien, mais uniquement en anglais ou toute autre langue sans diacritiques. Je m'explique :
- darkside of the moon --> D.O.T.M. (OK)
- dark side of the moon --> D.S.O.T.M. (OK)
- confédération générale des nanas révolutionnaires --> C.D.R.G.N.R.D.N.R.V. (NO OK)
On sattendait à : C.G.D.N.R.
- comisión de los niños rebeldes --> C.N.D.L.N.O.R. (NO OK)
on s'attendait à : C.D.L.N.R.

 

[Dudu2]

Bonjour @Staple1600, @patricktoulon, @Magic_Doctor,
A défaut (pour moi en tous cas) de savoir comment expliciter les lettres accentuées en expression régulière, cette fonction.

 

[mapomme]

Bonjour à tous,

Ne pouvant pas me résoudre à délaisser ceux qui errent désespérément dans l'univers PC alors qu'ils utilisent un ustensile électronique de type "Apple" (mapomme forcément est solidaire), une version qui fonctionne dans les deux univers. Deux macros distinctes pouvant être utilisées séparément.

1. une fonction personnalisée pour les premières lettres: PremiersCar
2. une fonction personnalisée pour ôter les accents: SansAccent

Les codes :

Function PremiersCar$(ByVal s$, Optional ByVal sep As String = ".")
Dim r$, x
   For Each x In Split(Application.Proper(Application.Trim(s))): r = r & Left(x, 1) & sep: Next
   PremiersCar = r
End Function

Function SansAccent(ByVal x)
Const lettresAvec = "Ÿ,À,Á,Â,Ã,Ä,Å,Ç,È,É,Ê,Ë,Ì,Í,Î,Ï,Ñ,Ò,Ó,Ô,Õ,Ö,Ù,Ú,Û,Ü,Ý,à,á,â,ã,ä,å,ç,è,é,ê,ë,ì,í,î,ï,ñ,ò,ó,ô,õ,ö,ù,ú,û,ü,ý,ÿ"
Const lettresSans = "Y,A,A,A,A,A,A,C,E,E,E,E,I,I,I,I,N,O,O,O,O,O,U,U,U,U,Y,a,a,a,a,a,a,c,e,e,e,e,i,i,i,i,n,o,o,o,o,o,u,u,u,u,y,y"
Dim i&, j&
   For i = 1 To Len(x)
      j = InStr(lettresAvec, Mid(x, i, 1))
      If j > 0 Then x = Replace(x, Mid(x, i, 1), Mid(lettresSans, j, 1))
   Next i
   x = Replace(x, UCase("œ"), "OE"): x = Replace(x, "œ", "oe")
   x = Replace(x, UCase("æ"), "AE"): x = Replace(x, "æ", "ae")
   SansAccent = x
End Function