Pbm mois minuscule avec accent vers majuscule sans accent

Le 02/08/2024 à 09:23

Bonjour la communauté,

Je viens avec un petit détail que j'aimerais résoudre mais je souhaiterais votre aide.

Dans le code VBA suivant, je demande à enregistrer une pièce jointe sur une clé USB ou récupérer une PJ dans des dossiers comportant des noms de mois en majuscule. Le bémol c'est que par exemple pour le mois d'août qui en minuscule comporte un accent notamment sur le "u" et bien ça me renvoie l'erreur disant qu'il ne trouve pas le dossier.

Je vous sollicite donc afin de résoudre ce petit détail permettant de retrouver l'intégrité de fonctionnement de ma macro.

J'imagine que cela se reproduira aussi pour le mois de février.

Function GetSenderSMTPAddress(olItem As Object) As String

    Dim olPA As Object

    Dim olSender As Object

    Dim senderSMTP As String

    On Error Resume Next

    Set olPA = olItem.PropertyAccessor

    If Not olPA Is Nothing Then

        senderSMTP = olPA.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x5D01001F")

        If senderSMTP = "" Then

            Set olSender = olItem.Sender

            If Not olSender Is Nothing Then

                senderSMTP = olSender.SmtpAddress

            End If

        End If

    End If

    GetSenderSMTPAddress = senderSMTP

End Function

Sub EnregistrerDernierePieceJointeServeurExchange()

    Dim olApp As Object

    Dim olNamespace As Object

    Dim olFolder As Object

    Dim olItems As Object

    Dim olItem As Object

    Dim olAttachment As Object

    Dim saveFolder As String

    Dim savePath As String

    Dim senderEmail As String

    Dim attachmentName As String

    Dim foundEmail As Object

    Dim senderSMTP As String

    Dim newFileName As String ' Nouveau nom de fichier

    Dim ReceivedTime As Integer

    ' Chemin du dossier où enregistrer la pièce jointe sur la clé USB

    saveFolder = "G:\USB -xxx xxx - Xxxx\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Format(Date, "mmmm")) & "\" & Format(Date, "ddmmyyyy") & "\"

    'Ouvrir le dossier saveFolder

    Shell "explorer.exe " & Chr(34) & saveFolder & Chr(34), vbNormalFocus

    ' Adresse e-mail de l'expéditeur à rechercher (serveur Exchange)

    senderEmail = "xxxxxx.txxxxx@xxxxxx.FR" ' Modifier selon l'adresse e-mail de l'expéditeur

    ' Nom de la pièce jointe à rechercher

    attachmentName = "6xx.TXT" ' Modifier selon le nom de la pièce jointe recherchée

    ' Initialisation de l'application Outlook

    On Error Resume Next

    Set olApp = GetObject(, "Outlook.Application")

    On Error GoTo 0

    If olApp Is Nothing Then

        Set olApp = CreateObject("Outlook.Application")

        If olApp Is Nothing Then

            MsgBox "Outlook n'est pas installé sur cet ordinateur."

            Exit Sub

        End If

    End If

    ' Récupération de l'espace de noms Outlook

    Set olNamespace = olApp.GetNamespace("MAPI")

    Const olFolderInbox As Integer = 6

    ' Récupération du dossier Boîte de réception

    Set olFolder = olNamespace.GetDefaultFolder(olFolderInbox)

    'Vérification du succès de la récupération du dossier Boîte de réception

    If olFolder Is Nothing Then

        MsgBox "Impossible d'obtenir le dossier Boîte de réception."

        Set olNamespace = Nothing

        Set olApp = Nothing

        Exit Sub

    End If

    ' Récupération des e-mails triés par date d'arrivée décroissante

    Set olItems = olFolder.Items

    olItems.Sort "[ReceivedTime]", True

    Dim dCejour11h30 As Date

    Dim dCejour13h45 As Date

    Dim dCejour18h00 As Date

    Dim dCejour20h00 As Date

    dCejour11h30 = Date + (1 / 1440 * ((11 * 60) + 30))

    dCejour13h45 = Date + (1 / 1440 * ((13 * 60) + 45))

    dCejour18h00 = Date + (1 / 1440 * (18 * 60))

    dCejour20h00 = Date + (1 / 1440 * (20 * 60))

    ' Parcours des e-mails

    Set foundEmail = Nothing

    For Each olItem In olItems

        ' Vérification si l'élément est un e-mail et provient de l'expéditeur spécifié

        If TypeOf olItem Is Object  And olItem.Class = 43 Then ' 43 correspond à olMail (MailItem en early binding)

            ' Obtenir l'adresse SMTP de l'expéditeur

            senderSMTP = GetSenderSMTPAddress(olItem)

            ' Vérifier si l'e-mail provient de l'expéditeur spécifié

            If senderSMTP = senderEmail Then

                ' Vérifier si l'e-mail a déjà été traité et enregistré

                If Not olItem.UnRead Then

                    MsgBox "Le mail de l'expéditeur a déja été lu/traité, la pièce jointe a déjà été enregistrée sur la clé USB."

                    Exit Sub

                End If

                ' Parcours des pièces jointes de l'e-mail

                For Each olAttachment In olItem.Attachments

                    ' Vérifier si la pièce jointe a le nom recherché

                    If olAttachment.Filename = attachmentName Then

                        ' Construire le chemin complet pour enregistrer la pièce jointe

                        savePath = saveFolder & olAttachment.Filename

                        ' Vérifier si le fichier existe déjà sur la clé USB

                        If Not FileExistsOnUSB(savePath) Then

                            ' Enregistrer la pièce jointe sur la clé USB

                            olAttachment.SaveAsFile savePath

                            ' Déterminer le nouveau nom en fonction de l'heure de réception

                            If (olItem.ReceivedTime >= dCejour11h30 And olItem.ReceivedTime <= dCejour13h45) Then

                                newFileName = "6WW - 1430z.txt"

                            ElseIf (olItem.ReceivedTime >= dCejour18h00 And olItem.ReceivedTime <= dCejour20h00) Then

                                newFileName = "6WW - 2030z.txt"

                            End If

                            ' Renommer le fichier après l'avoir enregistré

                            Name savePath As saveFolder & newFileName

                            MsgBox "La pièce jointe a bien été enregistrée"

                            ' Marquer l'e-mail comme lu si nécessaire

                            olItem.UnRead = False

                            ' Conserver une référence à l'e-mail pour la gestion ultérieure si nécessaire

                            Set foundEmail = olItem

                        Else

                            ' La pièce jointe existe déjà sur la clé USB, ne rien faire dans ce cas

                            MsgBox "La pièce jointe '" & attachmentName & "' existe déjà sur la clé USB."

                        End If

                    End If

                Next olAttachment

            End If

        End If

        ' Sortir de la boucle externe après avoir trouvé le dernier e-mail de l'expéditeur spécifié

        If Not foundEmail Is Nothing Then Exit For

    Next olItem

    ' Libérer les objets

    Set olAttachment = Nothing

    Set olItem = Nothing

    Set olItems = Nothing

    Set olFolder = Nothing

    Set olNamespace = Nothing

    Set olApp = Nothing

    ' Afficher un message si aucune pièce jointe n'a été trouvée

    If foundEmail Is Nothing Then

        MsgBox "Aucun e-mail trouvé avec la pièce jointe '" & attachmentName & "' de l'expéditeur '" & senderEmail & "'."

    End If

    Set foundEmail = Nothing

End Sub

Function FileExistsOnUSB(saveFolder As String) As Boolean

    ' Vérifie si un fichier existe sur la clé USB à l'emplacement spécifié

    Dim fso As Object

    Set fso = CreateObject("Scripting.FileSystemObject")

    FileExistsOnUSB = fso.FileExists(saveFolder)

    Set fso = Nothing

End Function

Je vous remercie par avance pour le temps que vous consacrerez.

Le 02/08/2024 à 09:52

Bonjour,

Il faut créer une variable tableau contenant tous vos mois en minuscule avec accent,
ainsi vous pourrez aller chercher dans le bon sous-dossier

Le 02/08/2024 à 10:17

Bonjour,

merci de votre réponse. Qu'est ce que cela donnerait dans le code j'ai du mal à bien interpréter ?

Le 02/08/2024 à 12:24

bonjour guibs,JExcel2fr,

une possibilité:

saveFolder = "G:\USB -xxx xxx - Xxxx\MAJ CYCLE\" & Format(Date, "mm") & " - " & UCase(Replace(Replace(Format(Date, "mmmm"), "é", "e"), "û", "u")) & "\" & Format(Date, "ddmmyyyy") & "\"
Le 02/08/2024 à 12:27

Re,

Je n'irai pas mettre les mains dans ton code, mais voici un exemple

Sub Test()
  Dim ArMois() As String  ' Variable tableau
  Dim LesMois As String
  LesMois = "Nul,Janvier,Février,Mars,Avril,Mai,Juin,Juillet,Août,Septembre,Octobre,Décembre"
  ArMois = Split(LesMois, ",")
  MsgBox "Mois du jour : " & ArMois(Month(Date))
End Sub

A+

Edit : Salut BsAlv

Le 02/08/2024 à 15:57

re, salut JExceL2fr

les mois en plusieurs langues

Sub Mois()
Dim aFrancais, aAlemand, aEspagnol, aNeerlandais

aFrancais = Evaluate("text(column(offset(A1,,,,12))*28,""[$-fr-fr]mmmm"")")
aAlemand = Evaluate("text(column(offset(A1,,,,12))*28,""[$-de-de]mmmm"")")
aEspagnol = Evaluate("text(column(offset(A1,,,,12))*28,""[$-es-es]mmmm"")")
aNeerlandais = Evaluate("text(column(offset(A1,,,,12))*28,""[$-nl-nl]mmmm"")")
End Sub

et avec des majuscules

aFrancais_Maj = Evaluate("upper(substitute(substitute(text(column(offset(A1,,,,12))*28,""[$-fr-fr]mmmm""),""é"",""e""),""û"",""u""))")

MsgBox aFrancais_Maj(8)

Le 02/08/2024 à 16:53

Salut BsAlv,

Et ta sub fonctionne comment

Parce que chez moi à part une "erreur 13" j'ai rien d'autre

Le 02/08/2024 à 17:18

salut JExceL2fr,

je l'ai mis dans un fichier, vous avez encore cette erreur ? Où ?

6mois.xlsb (14.48 Ko)
Le 03/08/2024 à 14:22

Bonjour à tous,

Merci pour vos contributions. J'ai pu les tester et elles s'adaptent bien. En recherchant encore de mon côté j'ai pu trouver la fonction suivante :

Function RemoveAccentsAndToUpper(ByVal str As String) As String
    Dim accents As String
    Dim noAccents As String
    Dim i As Integer
    Dim output As String

    ' Caractères accentués et leurs équivalents non accentués en majuscules
    accents = "áàâäãåæçéèêëíìîïñóòôöõøœúùûüýÿ"
    noAccents = "AAAAAACEEEEIIIINOOOOOOOUUUUY"

    output = str
    For i = 1 To Len(accents)
        ' Remplacer les minuscules accentuées par des majuscules sans accent
        output = Replace(output, Mid(accents, i, 1), Mid(noAccents, i, 1))
        ' Remplacer les majuscules accentuées par des majuscules sans accent (au cas où)
        output = Replace(output, UCase(Mid(accents, i, 1)), Mid(noAccents, i, 1))
    Next i

    ' Convertir le reste en majuscule
    output = UCase(output)

    RemoveAccentsAndToUpper = output
End Function

Je l'ai adapté à mon code vba :

saveFolder = "G:\USB -xxx xxx - Xxxx\MAJ CYCLE\" & (Format(Date, "mm") & " - " & RemoveAccentsAndToUpper(UCase(Format(Date, "mmmm"))) & "\" & (Format(Date, "ddmmyyyy")) & "\"

Cela fonctionne pas mal aussi.

En tout cas merci pour votre aide à tous.

Le 04/08/2024 à 01:28

Bonjour,

A+

Rechercher des sujets similaires à "pbm mois minuscule accent majuscule"