Ce module est un générateur de message Lotus Notes qui apporte en plus, par rapport à ce qu'on trouve actuellement :
- La possibilité de générer un message sur toute autre boite aux lettre que la sienne, du moment qu'on a les bonnes ACL dessus.
- La gestion de l'écran de déconnexion de Lotus Notes lorsque celui-ci est activé.
- La mise en forme du corps du message via une syntaxe HTML.
Pour le moment, seule "<u>" (souligné), "<b>" (gras) et "<i>" (italique) ont été implémentés.
Pour mettre en place une nouvelle balise dans la procédure Genere_body :
- Ajouter la nouvelle balise à la suite de
Tbl_Style(0) = "<b>": Tbl_Style(1) = "<i>": Tbl_Style(2) = "<u>"
- Renseigner le Select Case Tbl_Style(b) d'activation
Select Case Tbl_Style(b)
Case "<b>" 'Gras
Style.Bold = True...
- Renseigner le Select Case Tbl_Style(b) de désactivation
Select Case Tbl_Style(b)
Case "<b>" 'Gras
Style.Bold = False...
Source / Exemple :
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
Conclusion :
Exemple d'implémentation :
Sub Envoi_Email()
Dim Serveur As String, BAL As String, Dest As Variant, Copie() As Variant, Invisible() As Variant, _
Sujet As String, Corps As String, Fichiers As Variant, Envoi As Boolean, Dossier_sauvegarde As String, Fenetre As Long
Serveur = "MAIL_08"
BAL = "Chemin\vers\la_BAL.nsf"
Dest = Array("Dest 1", "Dest 2", "Dest 3", "Dest 4")
Copie = Array("Copie 1", "Copie 2", "Copie 3", "Copie 4")
Dest = Array("Dest 1", "Dest 2", "Dest 3", "Dest 4")
Invisible = "Invisible 1"
Sujet = "Un petit mot de la Direction"
Corps = "<u>Florent Bénetière</u>, c'est <u><i>Florent Bénetière</i></u> je te dis." & vbCrLf & vbCrLf & "<b>Florent Bénetière</b>"
Fichiers = Array("C:\Chemin\vers\mon fichier 1.flo","C:\Chemin\vers\mon fichier 2.flo","C:\Chemin\vers\mon fichier 3.flo","C:\Chemin\vers\mon fichier 4.flo")
Envoi = True
Dossier_sauvegarde = "Envoyés"
While Not Envoi_Email_Lotus(Serveur, BAL, Dest, Copie, Invisible, Sujet, Corps, Fichiers, Envoi, Dossier_sauvegarde)
DoEvents
Wend
MsgBox "Message " & IIf(Envoi, "envoyé", "généré"), vbInformation, "Travaux effectués"
Fenetre = FindWindow("", "Travaux effectués")
ShowWindow Fenetre, 3 'SW_SHOW
End Sub
Pour celles et ceux qui voudraient avoir à peu près la même les cellules d'Excel, je vous invite à aller voir mon "Formatage d'une cellule Excel via une syntaxe HTML"
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.