IdentifiantMot de passe
Loading...
Mot de passe oublié ?Je m'inscris ! (gratuit)
Navigation

Inscrivez-vous gratuitement
pour pouvoir participer, suivre les réponses en temps réel, voter pour les messages, poser vos propres questions et recevoir la newsletter

Macros et VBA Excel Discussion :

Système d'hystorique vba excel [XL-2016]


Sujet :

Macros et VBA Excel

  1. #1
    Membre averti Avatar de ShadeKode
    Homme Profil pro
    Etudiant EPSI
    Inscrit en
    Juin 2018
    Messages
    19
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 26
    Localisation : France, Maine et Loire (Pays de la Loire)

    Informations professionnelles :
    Activité : Etudiant EPSI
    Secteur : High Tech - Matériel informatique

    Informations forums :
    Inscription : Juin 2018
    Messages : 19
    Par défaut Système d'hystorique vba excel
    Bonjour à tous,

    J'ai créer un code qui envoie des mails dynamiquement avec une pièce jointe dans laquelle il y a un publipostage word, généré lui aussi dynamiquement en fonction des personnes.
    Maintenant j'essaye de faire un historique de mes envois, j'ai produit un code qui devrait normalement fonctionner mais malheureusement ce n'est pas le cas, mais je ne sais pas pourquoi (peut etre une erreur tout bête de ma part ).

    Voici le code qui ne fonctionne pas :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    3
    4
    5
    6
    7
    8
    9
    10
    11
    12
    13
    14
     
            ResidencesH = Feuille.Cells(2, 1).Value
            For nblignes = 1 To NB
                Residences = Feuille.Cells(2, 1).Value
                If ResidencesH <> Residences Then
                    With Sheets("envoie de mail")
                        L = .Range("H65536").End(xlUp).Row + 1
                        .Range("H" & L).Value = Residences
                        .Range("I" & L).Value = Now()
                        .Range("J" & L).Value = Datesfact
                        .Range("K" & L).Value = Numfact
                    End With
                End If
            Next nblignes
    Voici le code entier avec les fonctions :

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
    59
    60
    61
    62
    63
    64
    65
    66
    67
    68
    69
    70
    71
    72
    73
    74
    75
    76
    77
    78
    79
    80
    81
    82
    83
    84
    85
    86
    87
    88
    89
    90
    91
    92
    93
    94
    95
    96
    97
    98
    99
    100
    101
    102
    103
    104
    105
    106
    107
    108
    109
    110
    111
    112
    113
    114
    115
    116
    117
    118
    119
    120
    121
    122
    123
    124
    125
    126
    127
    128
    129
    130
    131
    132
    133
    134
    135
    136
    137
    138
    139
    140
    141
    142
    143
    144
    145
    146
    147
    148
    149
    150
    151
    152
    153
    154
    155
    156
    157
    158
    159
    160
    161
    162
    163
    164
    165
    166
    167
    168
    169
    170
    171
    172
    173
    174
    175
    176
    177
    178
    179
    180
    181
    182
    183
    184
    185
    186
    187
    188
    189
    190
    191
    192
    193
    194
    195
    196
    197
    198
    199
    200
    201
    202
    203
    204
    205
    206
    207
    208
    209
    210
    211
    212
    213
    214
    215
    216
    217
    218
    219
    220
    221
    222
    223
    224
    225
    226
    227
    228
    229
    230
    231
    232
    233
    234
    235
    236
    237
    238
    239
    240
    241
    242
    243
    244
    245
    246
    247
    248
    249
    250
    251
    252
    253
    254
    255
    256
    257
    258
    259
    260
    261
    262
    263
    264
    265
    266
    267
    268
    269
    270
    271
     
    Option Explicit
     
    Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As Any, ByVal lpWindowName As Any) _
    As Long
     
    Private Declare Function SendMessage Lib "user32" _
    Alias "SendMessageA" (ByVal Hwnd As Long, ByVal wMsg As Long, _
    ByVal wParam As Long, lParam As Any) As Long
     
    Private Declare Function RegisterWindowMessage Lib "user32" _
    Alias "RegisterWindowMessageA" (ByVal lpString As String) As Long
    'Déclaration de la fonction AdresseEamilValide de type boellean qui va renvoyer true ou false
    'La Fonction attend un paramètre de type entier ByVal permet de prendre en compte seulement sa valeur
    Function VerificationAdresseEmail(ByVal email As String) As Boolean
     
        'Si il y a une reeur pendant l'exécution du code tu vas stocker l'erreur dans VerificationAdresseEmailIncorrecte
        On Error GoTo VerificationAdresseEmailIncorrecte
        'Définition des constantes
        Const CaracteresAutorise1 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890.!#$%&'*+-/=?^_`{|}~"
        Const CaracteresAutorise2 = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ1234567890.-"
        'Déclaration des variables de type chaine de caractères
        Dim AvantAdresseEmail, ApresAdresseEmail, AntiDoublePoint As String
        'Déclaration de variable de type entier
        Dim EmplacementArobase, i As Integer
     
        'On recherche le symbole @ dans la chaine de caractère attendu par la fonction
        'Cette recherche est affecté à la variable EmplacementArobase
        EmplacementArobase = InStr(1, email, "@")
        'Si la recherche retourne 0 on va faire un lien vers VerificationAdresseEmailIncorrecte
        'Qui sera la variable ou on stock tous nos erreurs
        If EmplacementArobase = 0 Then GoTo VerificationAdresseEmailIncorrecte
        'Si la recherche est supérieure à 0 on va faire un lien direct vers VerificationAdresseEmailIncorrecte
        If InStr(EmplacementArobase + 1, email, "@") > 0 Then GoTo VerificationAdresseEmailIncorrecte
     
        'La fonction Left permet de renvoyer le nombre de caractères de la chaine voulu en partent de la gauche
        'La variable AvantAdresseEmail va contenir tout ce qui se trouve avant le symbole @
        AvantAdresseEmail = Left(email, EmplacementArobase - 1)
        'La fonction Right permet de renvoyer le nombre de caractère de la chaine voulu en partent de la droite
        'la fonction len permet de déterminer le nombre de caractère dans une chaine
        'la variable ApresAdresseEmail va contenir tout ce qui se trouve à droite du symbole @ (y compris les points)
        ApresAdresseEmail = Right(email, Len(email) - EmplacementArobase)
        'La variable AntiDoublePoint va rechercher tout ce qui se trouve à droite du symbole @ et va sauvegarder la position des points
        AntiDoublePoint = Right(email, Len(email) - InStrRev(email, "."))
     
        'Début des conditions
        'Cette condition teste s'il y a un point au début de la chaine de caractère AvantAdresseEmail et à la fin de cette chaine
        If Left(AvantAdresseEmail, 1) = "." Or Right(AvantAdresseEmail, 1) = "." Then GoTo VerificationAdresseEmailIncorrecte
        'Cette condition teste s'il n'y a pas de point dans la chaine de caractère ApresAdresseEmail
        If InStr(1, ApresAdresseEmail, ".") = 0 Then GoTo VerificationAdresseEmailIncorrecte
        'Cette condition teste s'il y a un point au début de la chaine de caractère ApresAdresseEmail et à la fin de cette chaine
        If Left(ApresAdresseEmail, 1) = "." Or Right(ApresAdresseEmail, 1) = "." Then GoTo VerificationAdresseEmailIncorrecte
        'Cette condition teste s'il y a un tiret au début de la chaine de caractère ApresAdresseEmail et à la fin de cette chaine
        If Left(ApresAdresseEmail, 1) = "-" Or Right(ApresAdresseEmail, 1) = "-" Then GoTo VerificationAdresseEmailIncorrecte
        'Cette condition teste s'il y a moins de deux caractère dans la chaine de caractère AntiDoublePoint
        If Len(AntiDoublePoint) < 2 Then GoTo VerificationAdresseEmailIncorrecte
     
        'Cette boucle vérifie chaque caractère de la variable AvantAdresseEmail n'est pas différent des caractères
        'situés dans la variable CaracteresAutorise1
        For i = 1 To Len(AvantAdresseEmail)
            If InStr(1, CaracteresAutorise1, Mid(AvantAdresseEmail, i, 1)) = 0 Then GoTo VerificationAdresseEmailIncorrecte
        Next i
        'Cette boucle vérifie chaque caractère de la variable ApresAdresseEmail n'est pas différent des caractères
        'situés dans la variable CaracteresAutorise1
        For i = 1 To Len(ApresAdresseEmail)
            If InStr(1, CaracteresAutorise2, Mid(ApresAdresseEmail, i, 1)) = 0 Then GoTo VerificationAdresseEmailIncorrecte
        Next i
        'Cette boucle vérifie qu'il n'y a pas deux points de suite dans la chaine de caractère entrée par l'utilisateur
        For i = 1 To Len(email)
            If Mid(email, i, 1) = "." And Mid(email, i + 1, 1) = "." Then GoTo VerificationAdresseEmailIncorrecte
        Next i
        'Si toutes les conditions n'ont pas retourné d'erreur tu quitte la fonction et tu retournes True
        VerificationAdresseEmail = True
        Exit Function
    'Si une des conditions a retourné une erreur tu quittes la fonction et tu retournes False
    VerificationAdresseEmailIncorrecte:
        VerificationAdresseEmail = False
    End Function
    'Déclaration de la fonction VerifierDossierEtSousDossier de type boellean qui va renvoyer true ou false
    'La Fonction attend un paramètre de type entier
    Function VerifierDossierEtSousDossier(DossierOuSousDossier As String) As Boolean
    Dim DecouperDossierOuSousDossier, DecouperDossierOuSousDossier2, CheminPartiel, CheminPartielOK As Variant
     
     
        'Si il y a une reeur pendant l'exécution du code tu vas stocker l'erreur dans VerifierDossierEtSousDossierErreur
        On Error GoTo VerifierDossierEtSousDossierErreur
     
    'cette fonction vérifi si le répertoire ou dossier de l'utilisateur existe déja
    'Len permet de conter le nombre de caractère
    'Dir renvoie une valeur entier représentant le non du dossier ou fichier il prend en paramètre
    'le chemin d'accès et un attributs ici vbDirectory qui permet dans qu'elle dossier ou sous dossier il est situé
    If Len(Dir(DossierOuSousDossier, vbDirectory)) > 0 Then
    VerifierDossierEtSousDossier = True
    Exit Function
    Else
    'si le fichier ou dossier n'existe pas
            'Cette ondition teste si il y a un \ à la fin de la chaine de caractère DossierOuSousDossier
            If Right(DossierOuSousDossier, 1) = Application.PathSeparator Then
                'DossierOuSousDossier est égal au nombre de caratère -1 pour enlever le symbole \
                DossierOuSousDossier = Left(DossierOuSousDossier, Len(DossierOuSousDossier) - 1)
                'ici on va extraire les donnée qui sont séparé par le symbole \ dans la chaine
                'de carractère DecouperDossierOuSousDossier, ce qui va renvoyer un tableau unidimensionnel de base zéro
                DecouperDossierOuSousDossier = Split(DossierOuSousDossier, Application.PathSeparator)
     
            'Cette boucle permet déterminer la taille du tableau DecouperDossierOuSousDossier créer antérièrement
            For DecouperDossierOuSousDossier2 = LBound(DecouperDossierOuSousDossier) To UBound(DecouperDossierOuSousDossier)
     
                For CheminPartiel = LBound(DecouperDossierOuSousDossier) To DecouperDossierOuSousDossier2
     
                    CheminPartielOK = CheminPartielOK & DecouperDossierOuSousDossier(CheminPartiel) & Application.PathSeparator
     
                    If CheminPartiel = DecouperDossierOuSousDossier2 Then
     
                        If Len(Dir(CheminPartielOK, vbDirectory)) = 0 Then
                            MkDir CheminPartielOK
                        End If
     
                    End If
     
                Next CheminPartiel
                CheminPartielOK = ""
            Next DecouperDossierOuSousDossier2
            End If
    End If
     
    VerifierDossierEtSousDossier = True
    Exit Function
    VerifierDossierEtSousDossierErreur:
    VerifierDossierEtSousDossier = False
    End Function
    Private Sub email_Click()
        Dim ObjOutlook As Outlook.Application
        Dim oBjMail
        Dim Piecejointe As Variant
        Dim base, Model, Rep, Dossier, Fiche, Destinataire, Nom, Prenom, Dates, MonDossier, Residences, DossierComplet, Numappt, Numfact, Datesfact, ResidencesH, VerificationEmail As String
        Dim Feuille As Worksheet
        Dim L As Long
        Dim WordApp As Object ' Application Word
        Dim WordDoc As Object ' Document Word
        Dim i, nblignes As Integer
        Dim NB As Variant
        Dim lngHWnd, lngClickYes As Long
        Dim OutlookDejaOuvert As Boolean
     
        OutlookDejaOuvert = True
        Set ObjOutlook = Outlook.Application
        Set Feuille = Worksheets("MAIL")
        Feuille.PivotTables("Tableau croisé dynamique1").PivotCache.Refresh
        NB = Application.CountA(Sheets("MAIL").Range("A2:A65536"))
        L = 2
        If ObjOutlook.ActiveWindow Is Nothing Then
            Set ObjOutlook = CreateObject("Outlook.Application")
            OutlookDejaOuvert = False
        End If
     
        For i = 1 To NB
        Set oBjMail = ObjOutlook.CreateItem(olMailItem)
     
            Destinataire = Feuille.Cells(L, 12).Value
            Nom = Feuille.Cells(L, 6).Value
            Prenom = Feuille.Cells(L, 7).Value
            Dates = Feuille.Cells(L, 3).Value
            Residences = Feuille.Cells(L, 1).Value
            Numappt = Feuille.Cells(L, 5).Value
            Numfact = Feuille.Cells(L, 14).Value
            Datesfact = Feuille.Cells(L, 13).Value
     
            ' Désactive l'actualisation de l'écran (accélère l'exécution du code)
            Application.ScreenUpdating = False
            Application.DisplayAlerts = False
     
            ' Définition des variables
            base = ActiveWorkbook.Path & "\test.xlsm"
            Model = ActiveWorkbook.Path & "\test.docx"
            Dossier = ActiveWorkbook.Path & "\Factures\"
            'cette fonction vérifi si le répertoire Factures existe ou pas, si n'existe pas il le créer
            If Not Len(Dir(Dossier, vbDirectory)) > 0 Then MkDir Dossier
     
            ' Ouvre une session word (création de fichier)
            Set WordApp = CreateObject("Word.Application")
            ' Cache le document Word
            WordApp.Visible = False
            ' Ouvre le document souhaité
            Set WordDoc = WordApp.Documents.Open(Model, ReadOnly:=False)
                'début d'éxecution d'une série
                With WordDoc.MailMerge
                    'Ouvre la base
                    .OpenDataSource Name:=base, Connection:="Driver={Microsoft Excel Driver (*.xls)};" & _
                    "DBQ=" & base & "; ReadOnly=True;", SQLStatement:="SELECT * FROM [MAIL$]"
                    .suppressBlankLines = True 'Suppression des lignes blanches
     
                    'nombre d'enregistrement à associé
                    With .DataSource
                    .FirstRecord = i 'de 1
                    .LastRecord = i ' à 1
                    End With
                    'Exécute l'opération de publipostage
                    .Execute Pause:=False
                End With
     
                VerificationEmail = VerificationAdresseEmail(Destinataire)
     
               If VerificationEmail = False Then
                    Destinataire = "Facture de" & Residences & "-" & Numappt & "-" & Datesfact & "-" & Numfact & "@espaceetvie.fr"
               End If
     
                    Rep = Residences & "\"
     
                    DossierComplet = Dossier & Rep
                    VerifierDossierEtSousDossier (DossierComplet)
     
                    ' Définition du non du fichier
                    Fiche = DossierComplet & Residences & "-" & Numappt & "-" & Nom & "-" & Prenom & "-" & Datesfact & "-" & Numfact
                            'enregistrement du fichier en PDF
                    WordDoc.Application.ActiveDocument.ExportAsFixedFormat OutputFileName:= _
                        Fiche, ExportFormat:= _
                        17, OpenAfterExport:=False, OptimizeFor:= _
                        0, Range:=0, From:=i, To:=NB, _
                        Item:=0, IncludeDocProps:=True, KeepIRM:=True, _
                        CreateBookmarks:=0, DocStructureTags:=True, _
                        BitmapMissingFonts:=True, UseISO19005_1:=False
     
                        WordApp.ActiveDocument.Saved = True
                        WordApp.ActiveDocument.Close
                        WordDoc.Close False 'ferme le document word en sauvegardant les données
                        WordApp.Quit 'ferme la session Word
     
                        Set WordApp = Nothing
                        Set WordDoc = Nothing
     
                 Piecejointe = Fiche & ".pdf"
     
                With oBjMail
                    .To = Destinataire
                    .Subject = "Espace & Vie - Facture de" & Residences & "-" & Numappt & Nom & "-" & Prenom & "-" & Datesfact & "-" & Numfact
                    .BodyFormat = olFormatRichText
                    .Body = "Madame, Monsieur," & vbLf & vbLf & "Veuillez trouvez, ci-joint, votre facture comme convenu contractuellement." & vbLf & vbLf & "Bien cordialement" & vbLf & vbLf & "Monique GUILLET" & vbLf & "0800111300" & vbLf & " "
                    .Attachments.Add Piecejointe
                    .Send
                End With
     
                L = L + 1
        Next i
     
            ResidencesH = Feuille.Cells(2, 1).Value
            For nblignes = 1 To NB
                Residences = Feuille.Cells(2, 1).Value
                If ResidencesH <> Residences Then
                    With Sheets("envoie de mail")
                        L = .Range("H65536").End(xlUp).Row + 1
                        .Range("H" & L).Value = Residences
                        .Range("I" & L).Value = Now()
                        .Range("J" & L).Value = Datesfact
                        .Range("K" & L).Value = Numfact
                    End With
                End If
            Next nblignes
     
        If (Not (WordApp Is Nothing)) Then Set WordApp = Nothing
        If (Not (WordDoc Is Nothing)) Then Set WordDoc = Nothing
        If OutlookDejaOuvert = False Then
            ObjOutlook.Quit
            SendMessage lngHWnd, lngClickYes, 1, 0
            If (Not (oBjMail Is Nothing)) Then Set oBjMail = Nothing
            If (Not (ObjOutlook Is Nothing)) Then Set ObjOutlook = Nothing
        End If
        Application.ScreenUpdating = True
        Application.DisplayAlerts = True
        MsgBox "Emails envoyés"
    End Sub
    et voici le résultat visuel, comme vous pouvez le voir je veut qu'après chaque envoie email il me face un historique des Résidences qui ont été traités avec leurs infos
    Nom : Capture.PNG
Affichages : 198
Taille : 77,6 Ko

  2. #2
    Rédacteur/Modérateur

    Avatar de Jean-Philippe André
    Homme Profil pro
    Architecte Power Platform, ex-Développeur VBA/C#/VB.Net
    Inscrit en
    Juillet 2007
    Messages
    14 682
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 41
    Localisation : Canada

    Informations professionnelles :
    Activité : Architecte Power Platform, ex-Développeur VBA/C#/VB.Net
    Secteur : Finance

    Informations forums :
    Inscription : Juillet 2007
    Messages : 14 682
    Par défaut
    Salut,

    quelle est la valeur de ta variable L après la ligne suivante ?

    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    1
    2
    With Sheets("envoie de mail")
                        L = .Range("H65536").End(xlUp).Row + 1
    Cycle de vie d'un bon programme :
    1/ ça fonctionne 2/ ça s'optimise 3/ ça se refactorise

    Pas de question technique par MP, je ne réponds pas

    Mes ouvrages :
    Migrer les applications VBA Access et VBA Excel vers la Power Platform
    Apprendre à programmer avec Access 2016, Access 2019 et 2021

    Apprendre à programmer avec VBA Excel
    Prise en main de Dynamics 365 Business Central

    Coffrets disponibles de mes ouvrages : https://www.editions-eni.fr/jean-philippe-andre
    Pensez à consulter la FAQ Excel et la FAQ Access

    Derniers tutos
    Excel et les paramètres régionaux
    Les fichiers Excel binaires : xlsb,

    Autres tutos

  3. #3
    Membre averti Avatar de ShadeKode
    Homme Profil pro
    Etudiant EPSI
    Inscrit en
    Juin 2018
    Messages
    19
    Détails du profil
    Informations personnelles :
    Sexe : Homme
    Âge : 26
    Localisation : France, Maine et Loire (Pays de la Loire)

    Informations professionnelles :
    Activité : Etudiant EPSI
    Secteur : High Tech - Matériel informatique

    Informations forums :
    Inscription : Juin 2018
    Messages : 19
    Par défaut
    Tout d'abord merci de ta réponse

    J'ai repris mon code à tête reposer et j'ai trouvé mon erreur, j'avais mal géré mes incrémentations avec ma fonction for.

    Voici le code fonctionel
    Code : Sélectionner tout - Visualiser dans une fenêtre à part
    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
     
            NB = Application.CountA(Sheets("MAIL").Range("A1:A65536"))
     
            For nblignes = 2 To NB
                ResidencesH = Feuille.Cells(2, 1).Value
                Residences = Feuille.Cells(nblignes, 1).Value
                If nblignes = 2 Then
                    With Sheets("envoie de mail")
                        L = .Range("H65536").End(xlUp).Row + 1
                        .Range("H" & L).Value = Residences
                        .Range("I" & L).Value = Now()
                        .Range("J" & L).Value = Datesfact
                        .Range("K" & L).Value = Numfact
                    End With
                End If
                If ResidencesH <> Residences Then
                    With Sheets("envoie de mail")
                        L = .Range("H65536").End(xlUp).Row + 1
                        .Range("H" & L).Value = Residences
                        .Range("I" & L).Value = Now()
                        .Range("J" & L).Value = Datesfact
                        .Range("K" & L).Value = Numfact
                    End With
                End If
            Next nblignes
    Merci encore pour ton m'avoir répondu

+ Répondre à la discussion
Cette discussion est résolue.

Discussions similaires

  1. [VBA-Excel,VB6,Fichier texte]enregistrer un classeur excel..
    Par Tarul dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 11/01/2005, 13h09
  2. [vba-excel] Le temps de fermeture trop court ?
    Par Damsou dans le forum Macros et VBA Excel
    Réponses: 2
    Dernier message: 11/01/2005, 10h03
  3. [VBA-Excel]
    Par Damsou dans le forum Macros et VBA Excel
    Réponses: 6
    Dernier message: 05/01/2005, 10h17
  4. [VBA EXCEL] Réduire/Agrandir UserForms
    Par Fench dans le forum Macros et VBA Excel
    Réponses: 3
    Dernier message: 06/11/2003, 16h02
  5. [VBA Excel] Effacer rapidement une feuille
    Par Invité dans le forum Macros et VBA Excel
    Réponses: 4
    Dernier message: 24/10/2002, 13h12

Partager

Partager
  • Envoyer la discussion sur Viadeo
  • Envoyer la discussion sur Twitter
  • Envoyer la discussion sur Google
  • Envoyer la discussion sur Facebook
  • Envoyer la discussion sur Digg
  • Envoyer la discussion sur Delicious
  • Envoyer la discussion sur MySpace
  • Envoyer la discussion sur Yahoo