Soyez le premier à donner votre avis sur cette source.
Snippet vu 9 423 fois - Téléchargée 18 fois
Option Explicit 'Pour trouver une fenêtre ouverte Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _ ByVal lpClassName As String, _ ByVal lpWindowName As String) As Long 'Pour faire passer une fenêtre au premier plan Public Declare Function ShowWindow Lib "user32" ( _ ByVal hwnd As Long, _ ByVal nCmdShow As Long) As Long Public Function NbreProcess(ByVal ProcessName As String) As Byte Dim svc As Object Dim sQuery As String Dim oproc As Variant Dim Compteur As Byte On Error Resume Next Set svc = GetObject("winmgmts:root\cimv2") sQuery = "select * from win32_process where name='" & ProcessName & "'" For Each oproc In svc.execquery(sQuery) Compteur = Compteur + 1 Next Set svc = Nothing NbreProcess = Compteur On Error GoTo 0 End Function Public Function Envoi_Email_Lotus(Serveur As String, BAL As String, Optional Dest As Variant = "", Optional Copie As Variant = "" _ , Optional Invisible As Variant = "", Optional Sujet As String = "", Optional Corps As String, Optional Doc_joint As Variant = "", _ Optional Envoi As Boolean = False, Optional Dossier_sauvegarde As String = "Envoyés") Dim Session As Object, Base As Object, Espace As Object, Email As Object, Body As Object, PJ As Object, i As Long Dim Style As Object, Fenetre As Long 'Serveur est le nom du serveur sans la partie après les "/" (exemple : "LOTUS_MAIL_8" au lieu de "LOTUS_MAIL_8/SERVER/GROUP" 'BAL est le chemin vers la base (exemple : "Chemin\vers\La_base.nsf") 'Les variables Dest, Copie,Invisible et Doc_joint permette de mettre une ou plusieurs valeurs dans les parties correspondantes du message 'Si ce sont des tableaux, il faut qu'ils commencent en indice 0 ! 'Pour un destinataire et/ou une personne en copie et/ou une personnes en invisible et/ou un fichier 'Considere la variable comme String 'Exemple Dest="Destinataire" 'Pour mettre plusieurs destinataires et/ou plusieurs personnes en copie et/ou plusieurs personnes en invisible 'Faire un tableau avec les variables Dest et/ou Copie et/ou Invisible 'Exemple : Dest=Array("Personne 1","Personne 2","Personne 3","Personne 4") 'La valeur de Doc_joint est le chemin vers le fichier Exemple: "C:\Mes documents\Pièce jointe.txt" 'Pour joindre plusieurs fichiers créer un tableau 'Exemple : Doc_joint=Array("C:\apps\lotus\notes\dmsecadm.dll","C:\apps\lotus\notes\dunzip32.dll") 'Si Envoi est True le message est automatiquement envoyé Const EMBED_ATTACHMENT As Integer = 1454 Const EMBED_OBJECT As Integer = 1453 Const EMBED_OBJECTLINK As Integer = 1452 On Error GoTo Erreurs 'Si Lotus Notes n'est pas ouvert on le fait 'On regarde si Notes est ouvert et boucle tant que cela n'est pas le cas Lance_Lotus 'Lorsque Lotus Notes est verrouillé, tant que l'utilisateur n'a pas débloqué cette application, la base ne peut pas s'ouvrir. 'On le prévient et on tourne en boucle jusqu'à ce que Lotus Notes soit accessible Fenetre = FindWindow("Notes", "Ecran de déconnexion") If Fenetre Then MsgBox "Votre Lotus Notes est verrouillé par l'écran de déconnexion." & vbCrLf & _ "Veuillez, s'il vous plaît, saisir votre mot de passe afin de poursuivre la génération du courriel.", vbInformation, "Lotus Notes verrouillé" While FindWindow("Notes", "Ecran de déconnexion") > 0 DoEvents Wend End If ' Création de la connexion avec Lotus Notes et du mail Set Session = CreateObject("Notes.NotesSession") 'On ouvre la base Set Espace = CreateObject("Notes.NotesUIWorkspace") Set Base = Session.GetDatabase(Serveur, BAL) Base.OPENMAIL While Base.IsOpen = False 'On est obligé de faire une boucle sur la récupération de la base car, lorsque Notes se déverrouille, Set Base = Session.GetDatabase(Serveur, BAL) 'Session.GetDatabase(Serveur, BAL) ne fonctionne qu'au second coup Base.OPENMAIL DoEvents Wend Set Style = Session.CreateRichTextStyle Set Email = Base.CreateDocument 'Construction du Email With Email .Form = "Memo" '.From = "Moi" 'inutile .SendTo = Dest .CopyTo = Copie .BlindCopyTo = Invisible .Subject = Sujet Set Body = .CREATERICHTEXTITEM("Body") Genere_body Corps, Body, Style If IsArray(Doc_joint) Then If UBound(Doc_joint) > 0 Then For i = 0 To UBound(Doc_joint) Set PJ = Body.EmbedObject(EMBED_ATTACHMENT, "", Doc_joint(i)) Next i End If ElseIf Len(Doc_joint) > 0 Then Set PJ = Body.EmbedObject(EMBED_ATTACHMENT, "", Doc_joint, Dir(Doc_joint)) End If If Envoi Then .Send False .Save True, False, False .PutInFolder Dossier_sauvegarde, True Else Espace.EDITDOCUMENT True, Email End If End With Set Session = Nothing: Set Base = Nothing: Set Espace = Nothing: Set Email = Nothing Envoi_Email_Lotus = True Exit Function Erreurs: If Err.Number = 28363 Then Resume Next ElseIf Err.Number = 429 Then 'Un composant ActiveX ne peut pas créer d'objet 'Cela se produit lorsque Lotus Notes n'a pas été ouvert au moment de la génération du mail 'à la ligne Set Espace = CreateObject("Notes.NotesUIWorkspace") 'Tant que Lotus Notes n'est pas complètement ouvert et disponible, et comme on boucle en amont sur l'envoi du message (while Envoi_Email_Lotus=False), on sort de la fonction 'pour que la fois d'après l'objet Espace puisse être créé. Exit Function ElseIf Err.Number = -2147417851 Then 'Erreur Automation Le serveur a généré une exception. MsgBox "Le serveur " & Serveur & " n'a pas généré votre message" & vbCrLf & "Veuillez réessayer ultérieurement.", vbCritical, "Message non généré" ElseIf Err.Number = 7060 Then MsgBox "Vous n'avez pas accès à la base " & BAL, vbCritical, "Accès à " & BAL & " refusé" Else MsgBox Err.Description, vbCritical, "Erreur N° " & Err.Number End If Envoi_Email_Lotus = True Set Session = Nothing: Set Base = Nothing: Set Espace = Nothing: Set Email = Nothing End Function Public Sub Lance_Lotus() 'On regarde si Notes est ouvert et boucle tant que cela n'est pas le cas If NbreProcess("NlNotes.exe") = 0 Then MsgBox "Lotus Notes se lancera une fois que vous aurez répondu à ce message." & vbCrLf & "Veuillez vous identifier s'il vous plaît.", vbOKOnly, "Identification requise" Shell "C:\apps\lotus\notes\notes.exe =C:\apps\lotus\notes\data\notes.ini", vbMaximizedFocus End If While NbreProcess("NlNotes.exe") = 0 DoEvents Wend End Sub Private Sub Genere_body(Corps As String, Body As Object, Style as Object) 'Cette procédure pilote Lotus Notes pour adapter un texte formaté en HTML au format Notes Dim Longueur_message As Long, a As Integer, b As Integer, Balise As String, Tbl_Style(2) As String, Taille As Byte Tbl_Style(0) = "<b>": Tbl_Style(1) = "<i>": Tbl_Style(2) = "<u>" Taille = UBound(Tbl_Style) Longueur_message = Len(Corps) With Body For a = 1 To Longueur_message 10 For b = 0 To Taille 'On regarde s'il y a une ouverture de balise If Mid(Corps, a, Len(Tbl_Style(b))) = Tbl_Style(b) Then Select Case Tbl_Style(b) Case "<b>" 'Gras Style.Bold = True Balise = "<b>" Case "<i>" 'Italique Style.Italic = True Balise = "<i>" Case "<u>" 'Souligné Style.Underline = True Balise = "<u>" End Select a = a + Len(Balise) 'On ne met pas la balise ouvrante dans le corps de texte 'Dans l'hypothèse où des balises se suivent ou se ferment (Exemple : <b><i>Florent</i></b>), on fait un test sur les caractères suivants GoTo 10 Else 'On traite les balises de fermeture Balise = Replace(Tbl_Style(b), "<", "</") If Mid(Corps, a, Len(Balise)) = Balise Then Select Case Tbl_Style(b) Case "<b>" 'Gras Style.Bold = False Case "<i>" 'Italique Style.Italic = False Case "<u>" 'Souligné Style.Underline = False End Select a = a + Len(Balise) 'On ne met pas la balise fermante dans le corps de texte GoTo 10 End If End If Next b Balise = "" .AppendStyle Style .AppendText Mid(Corps, a, 1) Next a .Update End With End Sub
N'ayant plus accès pour le moment à Lotus Notes, je peux te donner des pistes pour ajouter un style pour une couleur
Exemple trouvé sur http://www.mrexcel.com/forum/excel-questions/317966-lotus-notes-font-style-visual-basic-applications.html
objNotesStyle.NotesColor = COLOR_RED
Call objNotesField.AppendStyle(objNotesStyle)
Correspondance des constantes de couleurs sur http://www.rtlib.com/rtlib/vwClasses/rtFontstyle*NotesColor*
Property Set/Get NotesColor As Integer
Notes color index:
COLOR_BLACK (0)
COLOR_BLUE (4)
COLOR_CYAN (7)
COLOR_DARK_BLUE (10)
COLOR_DARK_CYAN (13)
COLOR_DARK_GREEN (9)
COLOR_DARK_MAGENTA (11)
COLOR_DARK_RED (8)
COLOR_DARK_YELLOW (12)
COLOR_GRAY (14)
COLOR_GREEN (3)
COLOR_LIGHT_GRAY (15)
COLOR_MAGENTA (5)
COLOR_RED (2)
COLOR_WHITE (1)
COLOR_YELLOW (6)
STYLE_NO_CHANGE (255)
Exemple d'implémentation dans mon code :
'Appliquer le rouge
Case "<Rouge>" 'Rouge
Style.NotesColor = COLOR_RED
Balise = "<Rouge>"
'Ne plus appliquer le rouge
Case "<Rouge>" 'Rouge
Style.NotesColor = COLOR_BLACK
Balise = "<Rouge>"
Cordialement,
8Tnerolf8
super code pour envoyer des mail en automatique, très bien écrit et très claire, je l'ai testé et pu développer des envoies de mails.
Juste une petite question, je n'est pas réussi à rajouter une balise pour mettre une phrase en couleur.
Pouvez vous m'aider
Cordialement
Après différents essaie, ce qui a marché pour moi c'est ;
With Regle
.Global = True
.IgnoreCase = True
.Pattern = vbCrLf
Corps = .Replace(Corps, Chr(10))
End With
Je te propose, pour éviter d'avoir une ligne sautée en plus sur la chaîne de caractères du corps du message de suivre la procédure suivante (à creuser car couchée directement dans ce message):
Première solution : Au lieu d'utiliser des vbCrLf, voit ce que cela peut donner avec des chr(10) et des chr(13) car vbCrlf = chr(10) & chr(13)
Seconde solution :
- Référence la bibliothèque
Library VBScript_RegExp_55
C:\Windows\system32\vbscript.dll\3
Microsoft VBScript Regular Expressions 5.5
- En amont de Envoi_Email_Lotus, formate la chaîne de caratères qui servira de corps de message en remplaçant les "vbCrLf" par "
"
- Dans la procédure Genere_body ajoute
Dim Regle As New RegExp
Avant "With Body" ajoute
'On remplace les sauts de lignes consécutifs par un seul saut de ligne
With Regle
.Global = True
.IgnoreCase = True
.Pattern = "(?:
)+)"
Corps = .Replace(Corps, vbCrLf)
End With
Si les problèmes persistent, essaie de faire Regle.Replace avec chr(10) et / ou chr(13)
La seule chose qui gene c'est qu'à chaque retour a la ligne dans le message initiale, je me retrouve avec une ligne sautée en plus.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.