Contrat de maintenance

Bonjour on me demande de créer un fichier de contrat de maintenance

les macros je n y connais pas trop uniquement les simples mais les plus complexes je beugue

j arrive pas a faire les boucles

La macro :

• elle ouvre le fichier tout les matins 9H
• vérifie la date <K1>
• si le mot "alerte" <F5>= copie la ligne (corps du texte)
• envoie email autant de fois que le mot alerte apparait.

calcul "alerte" varie en fonction du temps 2 mois environ avant la date echeance

en vous remerciant de pouvoir m'aider

Sub TesteDate()

'envoie un mail si la date est dépassée

Dim sSujet, sBody, sAdresseMail, sAdresseRetour As String 'chaines pour le sujet, corps, adresse d'envoi, adresse de retour

Dim duree As Integer 'nbre de jours entre aujourd'hui et la date à tester

Dim Lig_Deb, Lig_Fin As Integer 'ligne de début, de fin

Dim sDates_Col, sMails_Col As String 'colonnes qui contiennent les dates à tester

Dim i As Integer

'initialisation des constantes de la macro :

Lig_Deb = 5 'dans ma feuille Excel, les dates à tester commencent en ligne 5

sDates_Col = "D" ' et elles sont en colonne D ( 4 ième colonne)

'initialisation des données du mail envoyé :

sSujet = "Contrat de maintenance :"

sBody = "Echeance !" + vbNewLine

sAdresseRetour = "L@hotmail.com"

'Ligne de fin =1ère cellule vide dans la colonne des dates

Lig_Fin = Val(Range(sDates_Col & CStr(Lig_Deb)).End(xlDown).Row)

' boucle de test dans la plage des dates (=> )

For i = Lig_Deb To Lig_Fin

Range(sDates_Col & CStr(i)).Select 'activer la cellule testée

duree = Now - ActiveCell.Value ' la date est dans la cellule active

If duree > 2 Then 'la date est dépassée

'MsgBox ("Envoi de courrier à " & sAdresseMail)

' envoyer le mail :

CDO_SendMail sSujet, sBody, sAdresseMail, sAdresseRetour

Else

'MsgBox ("La date n'est pas atteinte")

End If

Next i

End Sub

Sub CDO_SendMail(ByVal sSujet As String, ByVal sBody As String, ByVal sAdresseMail As String, ByVal sAdresseRetour)

'MARCHE IMPEC, sans demande de confirmation ))))

'on peut préciser : le sujet, le corps , l'adresse mail, l'adresse de retour

Dim iMsg As Object

Dim iConf As Object

Set iMsg = CreateObject("CDO.Message")

Set iConf = CreateObject("CDO.Configuration")

With iMsg

.Configuration = iConf

.To = sAdresseMail

.Sender = sAdresseRetour 'adresse de l'expéditeur pour le rapport envoyé

.From = sAdresseRetour 'adresse de l'expéditeur du mail

.ReplyTo = sAdresseRetour 'adresse à laquelle sera envoyée la réponse

.CC = ""

.BCC = ""

.Subject = sSujet 'sujet du message

.TextBody = sBody 'corps du message

'.AddAttachment Fichier 'fichier joint

' pour demander des confirmations de réception ou d'envoi :

.Fields("urn:schemas:mailheader:return-receipt-to") = sAdresseRetour

.Fields("urn:schemas:mailheader:disposition-notification-to") = sAdresseRetour

' Update fields

.Fields.Update

End With

End Sub

Apres correction je suis a ceci mais .send bloque donc pas d envoi

Sub DEMO_EnvoiMailCDO()
Dim mMessage As Object
Dim mConfig As Object
Dim mChps

    Set mConfig = CreateObject("CDO.Configuration")

    mConfig.Load -1
    Set mChps = mConfig.Fields
    With mChps
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        'Adapter suivant votre serveur de mail. (exemple pour Gmail.)=> Hormail "smtp.live.com"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
        'En principe, 25 fonctionne avec tout les serveurs.
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25

        'Vous pouvez essayer sans ces trois lignes
        'Mais si votre serveur demande une authentification,
        '.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = "1"
        '.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "laurent.vlb@gmail.com"
        '.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "*****"
        'Si votre serveur demande une connexion sûre (SSL)
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = "true"
        .Update
    End With

    With mMessage
    Set mMessage = CreateObject("CDO.Message")

    Set .Configuration = mConfig
        .To = "laurent_vl@hotmail.com"
        .From = "laurent.vlb@gmail.com"
        .Subject = "ALERTE"
        .TextBody = "Ce mail vous est envoyer pour LIRE LES CONTRATS DE MAINTENANCE"
        'Pour ajouter une pièce jointe, un fichier, classeur, image etc.
        '.AddAttachment 'Chemin et nom complet du fichier à joindre
        .send
    End With
    Set mMessage = Nothing
        'Pour ajouter une pièce jointe, un fichier, classeur, image etc.
        '.AddAttachment 'Chemin et nom complet du fichier à joindre
        .send
    End With
    Set mMessage = Nothing

    'Libère les ressources
    Set mConfig = Nothing
    Set mChps = Nothing
End Sub

Que pensez vous de ceci j ai un fichier qui se creer mais toujours pas d email que faire

Sub courriel()
Dim temp As String
temp = "C:\Users\alexis\Desktop\contrat.xlsm"
    Sheets("Contrat").Select
    Cells.Select
    Selection.Copy
    Workbooks.Add
    Cells.Select
    ActiveSheet.Paste
    Application.CutCopyMode = False
    ChDir "C:\"
    ActiveWorkbook.SaveAs Filename:="C:\Users\alexis\Desktop\contrat.xlsm", FileFormat:=xlNormal, _
        Password:="", WriteResPassword:="", ReadOnlyRecommended:=False, _
        CreateBackup:=False
    ActiveWindow.Close
Dim CdoMessage As Object
Dim fichier As Variant
    fichier = tem

    If fichier = False Then Exit Sub
    Set Cdo_Message.Configuration = GetSMTPServerConfig()
    Set CdoMessage = CreateObject("CDO.Message")

    With CdoMessage
        .Subject = "contrat"
        .From = "laurent.vlb@gmail.com"
        .To = "laurent_vl@hotmail.com"
        .CC = ""
        .BCC = ""
        .TextBody = "Alerte"
        .AddAttachment fichier
        .send
    End With

    Set CdoMessage = Nothing
    Kill temp
End Sub

Function GetSMTPServerConfig() As Object
' Microsoft CDO for Windows 2000 Library
    Const cdoSendUsingPickup = 1
    Const cdoSendUsingPort = 2
    Const cdoSendUsingMethod = "http://schemas.microsoft.com/cdo/configuration/sendusing"
    Const cdoSMTPServer = "http://schemas.microsoft.com/cdo/configuration/smtpserver"
    Const cdoSMTPServerPort = "http://schemas.microsoft.com/cdo/configuration/smtpserverport"

    Dim Cdo_Config As Object 'New CDO.Configuration
    Set Cdo_Config = CreateObject("CDO.Configuration")
    Dim Cdo_Fields As Object
    Set Cdo_Fields = Cdo_Config.Fields

    With Cdo_Fields
        .Item(cdoSendUsingMethod) = cdoSendUsingPort
        .Item(cdoSMTPServer) = "smtp@gmail.com" 'Adapter l'adresse SMTP
        .Item(cdoSMTPServerPort) = 465
        .Update
    End With

    Set GetSMTPServerConfig = Cdo_Config
    Set Cdo_Config = Nothing
    Set Cdo_Fields = Nothing

End Function