Envois de mail automatique

Question

Je vais essayer d'être assez claire. Dans mon fichier joins j'ai un onglet LIVRES et dès que ça arrive à 121 jours d'emprunts, une partie de la ligne concernant le numéro du livre va ce copier dans la feuille retard ici tout va bien mais j'aimerais que cela envois un mail automatiquement mais une fois toutes les deux semaines, lui précisant qu'elle détiens un livre dont l'emprunt et de tant de jour qu'il serait bien de le ramener. Est-ce possible de faire ça ? je vous laisse mon fichier d'exemple...

Steelson · Accepted Answer

Pluc complexe que ce à quoi je m'attendais ...

j'ai ajouté un onglet "paramètres email" et un module "envoi emails"

Option Explicit
Sub rappels()
Dim livre As Range
Dim cherche As Range
Dim drapeau As Boolean ' true = date limite dépassée (sup à limite) et rappel ancien si existant (sup à frequence)
Dim ligne As Double

For Each livre In Sheets("LIVRES").Range("B3:G" & Sheets("LIVRES").Range("B" & Rows.Count).End(xlUp).Row)
    If livre.Offset(0, 1).Value <> "" And livre.Offset(0, 1).Value <> 0 And livre.Offset(0, 2).Value > Range("limite").Value Then
        With Sheets("retard")

            ligne = .Range("A" & Rows.Count).End(xlUp).Row
            If ligne > 1 Then 'tri du plus récent rappel au plus ancien pour faire fonctionner correctement la recherche de la date du dernier rappel

                .Sort.SortFields.Clear
                .Sort.SortFields.Add Key:=.Range("F2"), SortOn:=xlSortOnValues, Order:=xlDescending, DataOption:=xlSortNormal
                With ActiveWorkbook.Worksheets("Retard").Sort
                    .SetRange Range("A2:F" & ligne)
                    .Header = xlNo
                    .MatchCase = False
                    .Orientation = xlTopToBottom
                    .SortMethod = xlPinYin
                    .Apply
                End With

            End If

            drapeau = True

            Set cherche = .Columns("D").Find(livre.Value & "|" & livre.Offset(0, 1).Value & "|" & livre.Offset(0, 5).Value, Range("D" & 1).End(xlDown), xlValues, xlWhole)
            If Not cherche Is Nothing Then
                If Now() - cherche.Offset(0, 2).Value < Range("frequence").Value Then
                    drapeau = False 'on passe à false si le rappel a déjà eu lieu moins de jour que le paramètre frequence
                End If
                Set cherche = Nothing
            End If

            If drapeau Then

                ligne = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Cells(ligne, 1) = livre.Value
                .Cells(ligne, 2) = livre.Offset(0, 1).Value
                .Cells(ligne, 3) = livre.Offset(0, 5).Value
                .Cells(ligne, 4) = livre.Value & "|" & livre.Offset(0, 1).Value & "|" & livre.Offset(0, 5).Value
                Set cherche = Sheets("Adherents").Columns("A").Find(livre.Offset(0, 5).Value, Range("A" & 1).End(xlDown), xlValues, xlWhole)
                If Not cherche Is Nothing Then
                    .Cells(ligne, 5) = cherche.Offset(0, 1)
                    Set cherche = Nothing
                End If
                If .Cells(ligne, 5) <> "" Then
                    envoi_email .Cells(ligne, 5).Value, Replace(Range("titre").Value, "<livre>", .Cells(ligne, 1)), Replace(Replace(Range("message").Value, "<livre>", .Cells(ligne, 1)), "<date_emprunt>", .Cells(ligne, 2))
                    .Cells(ligne, 6) = Now()
                End If

            End If
        End With
    End If
Next livre

End Sub
Sub envoi_email(destinataire As String, sujet As String, texte As String)
Dim messagerie As Object
Dim email As Object

    Set messagerie = CreateObject("Outlook.Application")
    Set email = messagerie.CreateItem(0)
    With email
        .To = destinataire
        .Subject = sujet
        .htmlbody = "<FONT FACE='Calibri'>" & texthtml(texte) & "</FONT>"
        .ReadReceiptRequested = True
        '.display
        .send
    End With
    Set email = Nothing
    Set messagerie = Nothing

End Sub

Function texthtml(cetexte As String)
Dim num_car As Double

    texthtml = ""
    For num_car = 1 To Len(cetexte)
        Select Case Asc(Mid(cetexte, num_car, 1))
        Case Is = 10
            texthtml = texthtml & "<br/>"
        Case Is = 39
            texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(cetexte, num_car, 1)))) & ";"
        Case Is > 127
            texthtml = texthtml & "&#" & Application.Trim(Str(Asc(Mid(cetexte, num_car, 1)))) & ";"
        Case Else
            texthtml = texthtml & Mid(cetexte, num_car, 1)
        End Select
    Next

End Function

29gestion-livres.xlsm (89.29 Ko)

Steelson · Answer

Beau code, assez complet, autant te laisser toi-même le compléter sauf si tu as besoin d'aide. Oui c'est possible ... il y a 2 questions : comment envoyer un mail, et comment ne l'envoyer que tous les x jours. Pour l'envoi d'un mail, avec outlook, le code est assez simple et tu as tous les ingrédients y compris l'adresse mail : Option Explicit Sub envoi() Dim messagerie As Object Dim email As Object Set messagerie = CreateObject("Outlook.Application") Set email = messagerie.CreateItem(0) With email .to = "quelqu@un.fr" .Subject = "test envoi mail" .body = "message" .send End With Set messagerie = Nothing Set email = Nothing End Sub Et pour ne l'envoyer que tous les x jours, c'est un peu plus complexe, il faudra restructurer le code de la feuille "Retards" en conservant la date du dernier rappel, voire de tous les rappels. Il faudra donc laisser les différents retards, ajouter une colonne date rappel, et tester s'il y a déjà eu un rappel et si oui depuis quand (le test se faisant sur le triplé Livre+DatePrêt+Emprunteur) Si tu souhaites un produit "fini", n'hésite pas...

Steelson · Answer

OUI C'est dans ton onglet "Adherents" OK; je vais te faire un produit fini si tu confirmes que tu peux mettre outlook...

Steelson · Answer

J'ai commencé, je vais terminer demain .....

roms30 · Answer

Bonjour Steelson je voudrais savoir car je suis débutant si vous pouviez me guidez pour faire quelque chose de similaire sur mon fichier le probléme est que pour moi si une date dasn la plage j3 a j250 contien date -1 ,date -2 date -3 ou date dépasser . pensez vous cela réalisable. merci a vous de votre aide cordialement romain...

Steelson · Answer

Le mail est trouvé ici Set cherche = Sheets("Adherents").Columns("A").Find(livre.Offset(0, 5).Value, Range("A" &amp; 1).End(xlDown), xlValues, xlWhole) If Not cherche Is Nothing Then .Cells(ligne, 5) = cherche.Offset(0, 1) Set cherche = Nothing End If...

roms30 · Answer

Votre fichier et formidable je voudrais savoir comment je peut modifier l'envoie pour qu'il ce fasse en smtp merci a tous de votre aide ...

Steelson · Answer

Excel se contente de préparer un courriel, je ne vois pas ce que vient faire le protocole smtp géré par outlook lui-même ce n'est pas une mais de multiples erreurs ... faut voir avec son auteur ! réparer les erreurs une par une ! et simplifier (trop complexe)...

roms30 · Answer

D'accord je vais voir pour trouver toutes mes erreurs . merci de votre aide . cordialement romain ...