1. Accueil
  2. Tous les snippets
  3. Snippets Visual Basic / VB.NET
  4. Générateur de mail lotus notes avec mise en forme via une syntaxe html

Générateur de mail lotus notes avec mise en forme via une syntaxe html

Soyez le premier à donner votre avis sur cette source.

Snippet vu 9 225 fois - Téléchargée 18 fois

Commenter

Contenu du snippet

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"

A voir également

Ajouter un commentaire

Commentaires

Signaler
Messages postés
9
Date d'inscription
vendredi 25 novembre 2005
Statut
Membre
Dernière intervention
19 août 2013
Bonsoir Martindi 37

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
Signaler

Bonjour,

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
Signaler
Messages postés
6
Date d'inscription
mercredi 21 octobre 2009
Statut
Membre
Dernière intervention
21 janvier 2011
Merci pour la réponse rapide !
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
Signaler
Messages postés
9
Date d'inscription
vendredi 25 novembre 2005
Statut
Membre
Dernière intervention
19 août 2013
Je n'ai pas connu ce genre de problèmes lorsque j'ai dû implémenter cette solution.
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)
Signaler
Messages postés
6
Date d'inscription
mercredi 21 octobre 2009
Statut
Membre
Dernière intervention
21 janvier 2011
Impec pour mon application.
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.
S'inscrire maintenant

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.

Du même auteur (cs_8Tnerolf8)