XL 2016 aide avec outlook adresse courriel

[dede869]

Bonjour a tous, j"ai un userform (etape1) qui sert a entre des donné de travailleur, lorsqu'une date est entré dans la textbox5 (date du dépôt du grief au superviseur), je veux envoyer un courriel a l'adresse courriel qui est inscrit tans la textbox8, et dans la colone AA de la feuille.

Sub EnvoiAutomatiqueMail()
Dim j&
If OutlookOuvert = False Then j = Shell("Outlook", vbNormalNoFocus)
For j = 3 To Cells(Rows.Count, 2).End(xlUp).Row
If Cells(j, 5) > Now And Cells(j, 7) <> "" And Cells(j, 28) = "" Then
Envoi "Bonjour Mr, " & " " & Cells(j, 1) & "," & " " & "votre grief # " & " " & Cells(j, 2) & " " & "-" & Cells(j, 3) & "," & " a été déposé le " & " " & " " & Cells(j, 5) & "" & " a votre superviseur immédit."
Cells(j, 28) = Now
ElseIf Cells(j, 11) <> "" And Cells(j, 29) = "" Then
Envoi "Bonjour Mr, " & " " & Cells(j, 1) & "," & " " & "votre grief # " & " " & Cells(j, 2) & " " & "-" & Cells(j, 3) & "," & " a été déposé le " & " " & " " & Cells(j, 11) & "" & " au surintendant."
Cells(j, 29) = Now
ElseIf Cells(j, 15) <> "" And Cells(j, 30) = "" Then
Envoi "Bonjour Mr, " & " " & Cells(j, 1) & "," & " " & "votre grief # " & " " & Cells(j, 2) & " " & "-" & Cells(j, 3) & "," & " a été déposé le " & " " & " " & Cells(j, 15) & "" & " au Resource Humaine."
Cells(j, 30) = Now
ElseIf Cells(j, 19) <> "" And Cells(j, 31) = "" Then
Envoi "Bonjour Mr, " & " " & Cells(j, 1) & "," & " " & " une demande d'arbitrage a été demandé le" & " " & Cells(j, 18) & " " & "pour votre grief # " & " " & Cells(j, 2) & " " & "-" & Cells(j, 3)
Cells(j, 31) = Now
End If
Next j
End Sub
Function Envoi(Corps$)
Dim OutlookApp As Object
Dim OutlookMail As Object
Set OutlookApp = CreateObject("Outlook.Application")
Set OutlookMail = OutlookApp.CreateItem(0)
On Error Resume Next
With OutlookMail
.Subject = "Dépôt de grief avant date d'échéance"
.To = Feuil2.[aa3]
.CC = Feuil2.[am3]
.Body = Corps
.Display 'pour voir
'.Send 'pour envoyer
End With
End Function
Function OutlookOuvert() As Boolean
Dim oOL As Object
On Error Resume Next
Set oOL = GetObject(, "Outlook.Application")
On Error GoTo 0
OutlookOuvert = Not (oOL Is Nothing)
Set oOL = Nothing
End Function

Merci de votre aide

 

[Lone-wolf]

Bonjour Dédé

Au cas où tu repassera par ici

Private Sub TextBox4_AfterUpdate()
If TextBox4 <> "" Then
Call EnvoiAutomatiqueMail
Else
Exit Sub
End If
End Sub

 

[dede869]

Bonjour Lone-wolf,

Merci pour ton aide, je me suis peut-être mal exprimé, ce dont j'ai besoin c'est lorsque je clic sur " Envoyer un email suite au dépôt de grief" gans l'étape 1, une boite outlook s'ouvre avec les donnée demandé, jusque la tout va bien, c'est au niveau de l'adresse du destinataire qui doit faire référence au contenu de la textbox8 dans l'étappe 1.

merci

 

[Lone-wolf]

Bonsoir dede

Je n'ais pas saisi. Et & Cells(j, 1) & vbLf & Msg, c'est quoi se Msg??? Je ne vois aucune référence et excel me signale une erreur. Et je ne sais pas où tu à été chercher ça

Function Envoi(Corps$)
  Dim OutlookApp As Object
  Dim OutlookMail As Object
  Set OutlookApp = CreateObject("Outlook.Application")
  Set OutlookMail = OutlookApp.CreateItem(0)
  On Error Resume Next
    With OutlookMail
      .Subject = "Dépôt de grief avant date d'échéance"
      .To = Feuil2.[aa3]
      .CC = Feuil2.[al3]
      .Body = Corps
      .Display 'pour voir
      '.Send 'pour envoyer
    End With
End Function

Deux fonctions et une macro pour un simple envois??? En plus il faut changer .To = Feuil2.[aa3] par .To = TextB0x8. Ceci est juste un simple exemple avec destinataires sur une feuille.

Sub Envoi_Mail()
Dim PremAdresse, Sujet, CrMessage, Chemin, Fichier As String
Dim NouveauClasseur As Workbook
Dim OlApp As Outlook.Application
Dim OlMail As MailItem

With Feuil1
PremAdresse = .Range("a2")
Sujet = .Range("b2")
CrMessage = .Range("c2")
Fichier = .Range("d2")
End With

Set OlApp = CreateObject("Outlook.Application")
Set OlMail = OlApp.CreateItem(olMailItem)
With OlMail
      .To = PremAdresse
      .Subject = Sujet
      .Body = CrMessage
      .Attachments.Add ""
      .Display
   End With
    Set OlMail = Nothing
    Set OlApp = Nothing
End Sub

 

[Lone-wolf]

Bonjour dede

J'ai apporté quelques modifications au fichier. La formule pour calculer le nombre de jours était érronée, je l'ai supprimé et mis la fonction DateDiff dans la macro.

Pour la formule il fallait écrire =SI(ET(D3="";G3="");"";E3-F3). Regarde bien comment j'ai fait et applique-le pour les autres formulaires. Cela concerne etape1.

En J3 c'est : =SI(OU(H3="";I3="");"";H3+NbrD), NbrD est la cellule nommée de la feuille jour de calendrier, regarde là aussi, j'ai donné un nom aux 4 premières cellules. Ceci évite d'écrire le nom d'une feuille dans une formule.

Enlève tous les & " " & qui sont après les textes (inutiles quand tu peux écrire comme ceci: "Bonjour Monsieur " & le nom & " votre assignation.... " etc.), et met une seule condition à chaque formulaire, pas besoin de les mettre toutes, puisque tu as 4 formulaires.

Supprime la macro Outlook dans Thisworkbook, vu que tu passe par les formulaires pour envoyer les messages. À corriger aussi étappes dans les labels, par étape.

 

[dede869]

Ok merci beaucoup j'ai réglé presque tous les problème, j'ai un autre petit question, je doit verrouillez les colonne avec entête rouge et les colonne avec des formule a l'intérieur, lorsque je vais enregistré il va y avoir un bug, il doit y avoir un moyen d'entré un code vba pour déverrouillé et re-verrouiller .

Merci

 

[Lone-wolf]

Bonsoir dede

Oui. À l'ouverture du classeur, tu met Activesheet.Protect. Au début de la macro tu met Activesheet.Unprotect et à la fin avant End Sub tu remet Activesheet.Protect

 

[dede869]

Bonjour Lone-wolf,

Ok ça marche, mais je veut mettre un mot de passe pour oter la protection mais lorsque j'enregistre via étape 1 il me demande le mot de passe, comment faire pour qu'il n"y ai pas besoin d'entré le mot de passe lorsque je passe par les formulaire et me le demandé lorsque je clic sur oter la protection.

Merci

 

[Lone-wolf]

Essaie comme ceci. Si besoin, mettre quand même un mot de passe

ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
ActiveSheet.EnableSelection = xlUnlockedCells

ActiveSheet.Unprotect Password:=""

Avec test éffectué

Option Explicit
Public flag As Boolean
Sub test()
If flag = False Then
flag = True
ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, _
Scenarios:=True, AllowFormattingCells:=True
ActiveSheet.EnableSelection = xlUnlockedCells
MsgBox "Vous avez protegés la feuille.", , "PROTECTION"
Else
flag = False
ActiveSheet.Unprotect Password:=""
MsgBox "ATTENTION ! La feuille n'est plus protégée.", , "ALERTE"
End If
End Sub

 

[dede869]

Bonjour Lone-wolf,

J'ai inséré les deux code dans l'étape 1 "enregistré" oui ça fonctionne mais il change la protection des colonne G-I-K qui sont non protégé mais une fois cliquer sur enregistré il devienne protégé, de plus il efface les cadrage de ces cellule.

Et lorsque je clique sur "oter la protection" dans le ruban elle ne me demande pas de mot de passe, pour bien me faire comprendre, j'ai besoin que les formulaire fonctionne sans mot de passe pour enlevé la protection et je ne veut pas que personne enlève la protection via le ruban sans mot de passe.

J'ai inséré les code dans les autre étape sur la fonction "Modification" et pas de problème tout fonctionne.

Merci


Private Sub b_validation_Click_Click()
'--- Positionnement dans la base
Sheets("TABLEAU").Activate
'--- Doublon
Set result = ActiveSheet.Range("B2:B10000").Find(What:=Me.ComboBox2, LookIn:=xlValues, lookat:=xlWhole)
If Not result Is Nothing Then
MsgBox "code déjà existant"
Exit Sub
End If

ActiveSheet.Range("b65000").End(xlUp).Offset(1, 0).Select
ActiveSheet.Unprotect Password:=""
'--- Transfert Formulaire dans BD
With ActiveCell
.Value = Me.ComboBox2
.Offset(0, 0).Value = Me.ComboBox2 '# grief
.Offset(0, -1).Value = Me.TextBox1 'nom
.Offset(0, 1).Value = Me.TextBox2 'natur du grief
.Offset(0, 2).Value = Format(Me.TextBox3, FormulaLocal) ' Date de la sanction
.Offset(0, 5).Value = Format(Me.TextBox5, FormulaLocal) ' Date dépot grief
.Offset(0, 7).Value = Format(Me.TextBox7, FormulaLocal) 'date réponse employeur
.Offset(0, 25).Value = Format(Me.TextBox8, "@") 'Adresse courriel
.Offset(0, 18).Value = Me.ComboBox1 'Non de délégué responsable

End With
Application.Calculate
'--remise à blanc des zones
Me.ComboBox2 = ""
Me.TextBox1 = ""
Me.TextBox2 = ""
Me.TextBox3 = ""
Me.TextBox4 = ""
Me.TextBox5 = ""
Me.TextBox6 = ""
Me.TextBox7 = ""

lig = ActiveCell.Row
For col = 5 To 11
If Cells(lig, col).Value = 0 Then Cells(lig, col).Clear
Next col
ActiveSheet.Protect Password:="", DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowFormattingCells:=True
ActiveSheet.EnableSelection = xlUnlockedCells
If MsgBox("VOULEZ-VOUS CRÉÉ UNE TÂCHE POUR CE GRIEF?", vbYesNo) = vbYes Then
Creer_TacheOutlook
End If
End Sub

 

[Lone-wolf]

Bonsoir dede

Est-ce que tu as modifié au moins les paramètres de protection des cellules (sélectionner cellules déverouillées)??? Par-ce que moi j'ai enlever la protection sur un 10 aine de cellules et fais le test, je n'ai pas eu ce souci.

 

[dede869]

Bonjour Lone-wolf,

J'ai trouver le problème, c'étais cette commande qui amenais le problème, je l'ai éliminé.

Il reste la problème du mot de passe.

Merci de m'aidé c'est très apprécier.

lig = ActiveCell.Row
For col = 5 To 11
If Cells(lig, col).Value = 0 Then Cells(lig, col).Clear
Next col

 

[Lone-wolf]

La macro que j'ai mis, ne demande pas de mot de passe, que ce soit pour mettre ou pour ôter la protection.

 

[dede869]

Ça c'est ok lorsque j'utilise les formulaire, mais je veut que personne n'enlève la protection si le ruban de haut de l'écran.

 

[Lone-wolf]

Alors il faut protéger tout le classeur avec un mot de passe.