Bonjour,

Voici mon code à modifier afin d'activer le lien hypertexte. Je suis débutant dans le VBA, alors je compte sur vous pour me sauver la mise, bonne chance et merci d'avance

Code : Sélectionner tout - Visualiser dans une fenêtre à part
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
Option Explicit
 
Const EMBED_ATTACHMENT As Long = 1454
 
Sub EnvoiMail()
 
  Dim stFileName As String
  Dim vaRecipients As Variant
  Dim vaCopyTo As Variant
  Dim vaMsg As Variant
  Dim stSubject As Variant
  Dim stPath As String
 
  Dim noSession As Object
  Dim noDatabase As Object
  Dim noDocument As Object
  Dim noEmbedObject As Object
  Dim noAttachment As Object
  Dim stAttachment As String
 
  Dim Workspace As Object
  Dim EditDoc As Object
 
'Destinataire du mail A et CC ---- Début
    Dim cellule_début As String
    Dim ligne_dest_début As Integer
    Dim colonne_dest_A As Integer
    Dim colonne_dest_CC As Integer
    Dim ligne_dest_suite As Integer
    Dim colonne_mail As Integer
 
Dim Chemin As String
Chemin = Workbooks(ActiveWorkbook.Name).FullName
Range("D214").Value = Chemin
 
    cellule_début = ActiveSheet.Range("D200").Value
    ligne_dest_début = ActiveSheet.Range(cellule_début).Row
    colonne_dest_A = ActiveSheet.Range(cellule_début).Column
    colonne_dest_CC = colonne_dest_A + 1
    colonne_mail = colonne_dest_A + 5
 
 
    ligne_dest_suite = ligne_dest_début
    Do While ligne_dest_suite < ligne_dest_début + ActiveSheet.Range("D201").Value
        If ActiveSheet.Cells(ligne_dest_suite, colonne_dest_A).Value <> "" Then
            vaRecipients = vaRecipients & ", " & ActiveSheet.Cells(ligne_dest_suite, colonne_mail)
        End If
        ligne_dest_suite = ligne_dest_suite + 1
    Loop
 
    ligne_dest_suite = ligne_dest_début
    Do While ligne_dest_suite < ligne_dest_début + ActiveSheet.Range("D201").Value
        If ActiveSheet.Cells(ligne_dest_suite, colonne_dest_CC).Value <> "" Then
            vaCopyTo = vaCopyTo & ", " & ActiveSheet.Cells(ligne_dest_suite, colonne_mail)
        End If
        ligne_dest_suite = ligne_dest_suite + 1
    Loop
 
MsgBox "Mail A:" & vbCrLf & vaRecipients & vbCrLf & "Mail CC:" & vbCrLf & vaCopyTo
'Destinataire du mail A et CC ---- Fin
 
'Objet du mail
  stSubject = ActiveSheet.Range("D205").Value
 
'MsgBox vaRecipients(1)
 
'Corps du mail
Dim cellule As String
Dim cellule_col_check As String
Dim cellule_col_texte As String
Dim cellule_lin As String
 
'Définition de la cellule de début du texte
cellule_col_check = "C"
cellule_col_texte = "D"
cellule_lin = 210
 
 
' Pas toucher !!!! c'est pour la logique de boucle
cellule = ActiveSheet.Range(cellule_col_check & cellule_lin).Value
 
 
Do While cellule <> ""
 
'Construction du texte à adapter selon volonté
vaMsg = vaMsg & vbCrLf & ActiveSheet.Range(cellule_col_texte & cellule_lin)
 
 
 
' Pas toucher !!!! c'est pour la logique de boucle
cellule_lin = cellule_lin + 1
cellule = ActiveSheet.Range(cellule_col_check & cellule_lin).Value
Loop
 
' Titre de la boîte de message
MsgBox "Extrait du mail généré dans votre LOTUS NOTES" & vbCrLf & vaMsg
 
 
'Pas toucher LOTUS NOTES ***************************************************************************************************
  'Instantiate the Lotus Notes COM's Objects.
  Set noSession = CreateObject("Notes.NotesSession")
  Set noDatabase = noSession.GETDATABASE("", "")
 
  'If Lotus Notes is not open then open the mail-part of it.
  If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
'Create the e-mail and the attachment.
  Set noDocument = noDatabase.CreateDocument
'  Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
'  Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
'Add values to the created e-mail main properties.
  With noDocument
    .Form = "Memo"
    .SendTo = vaRecipients
    .CopyTo = vaCopyTo
    .Subject = stSubject
    .Body = vaMsg
  End With
 
  'Disable signature in users mail profile (dés-activation de la signature)
Dim SigDoc As Object
Dim iSig As Variant
Dim iSigOption_old As String
Dim iSigOption_new As String
 
Set SigDoc = noDatabase.GetProfileDocument("CalendarProfile")
iSigOption_old = SigDoc.GetItemValue("SignatureOption")(0)
If iSigOption_old <> "" Then
SigDoc.SignatureOption = ""
End If
 
'Show memo to UI/front end (création du mail en mode édition)
Set Workspace = CreateObject("Notes.NotesUIWorkspace")
Set EditDoc = Workspace.EditDocument(True, noDocument)
 
 
'Re-enable signature in users mail profile (Ré-activation de la signature avec l'ancienne valeur)
iSigOption_new = SigDoc.GetItemValue("SignatureOption")(0)
If Not iSigOption_new = iSigOption_old Then
SigDoc.SignatureOption = iSigOption_old
End If
 
Call EditDoc.FieldSetText("EnterCopyTo", vaCopyTo)
 
'Delete the temporarily workbook.
'  Kill stAttachment
'Release objects from memory.
'  Set noEmbedObject = Nothing
'  Set noAttachment = Nothing
  Set noDocument = Nothing
  Set noDatabase = Nothing
  Set noSession = Nothing
  Set Workspace = Nothing
  Set EditDoc = Nothing
End Sub
'Pas toucher LOTUS NOTES ***************************************************************************************************