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
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
| Option Compare Database
Option Explicit
Private Maildb As Object ' The Mail Database
Private Username As String ' The current users notes name
Private MailDbName As String ' The Current Users Notes mail database name
Private MailDoc As Object 'the mail document itself
Private AttachME As Object ' The attachement richtextfile object
Private session As Object ' The Notes Seesion
Private EmbedObj As Object ' The Embedded Object (attachment)
Private ws As Object 'Lotus Workspace
Private objProfile As Object
Private rtiSig As Object, rtitem As Object, rtiNew As Object
Private uiMemo As Object
Public strToArray() As String, strCCArray() As String, strBccArray() As String
'
Public Function f_SendNotesEmail(strTo As String, strCC As String, strBcc As String, _
strObject As String, strBody As String, strAttachment As String, blnSaveIt As Boolean) As Boolean
Dim strSignText As String, strMemoUNID As String
Dim intSignOption As Integer
Set session = CreateObject("Notes.NotesSession")
Set ws = CreateObject("Notes.NotesUIWorkspace")
Username = session.Username
MailDbName = Left$(Username, 1) & Right$(Username, (Len(Username) - InStr(1, Username, " "))) & ".nsf"
On Error GoTo err_send
Set Maildb = session.GETDATABASE("", MailDbName)
If Maildb.IsOpen = False Then Maildb.OPENMAIL
'Use Array for recipient list
s_RecipientList strToArray(), strTo
s_RecipientList strCCArray(), strCC
s_RecipientList strBccArray(), strBcc
Set MailDoc = Maildb.CREATEDOCUMENT
MailDoc.Form = "Memo"
MailDoc.SendTo = strToArray
MailDoc.CopyTo = strCCArray
MailDoc.BlindCopyTo = strBccArray
MailDoc.Subject = strObject
MailDoc.SAVEMESSAGEONSEND = blnSaveIt
Set objProfile = Maildb.GetProfileDocument("CalendarProfile")
intSignOption = objProfile.GetItemValue("SignatureOption")(0)
strSignText = objProfile.GetItemValue("Signature")(0)
If strAttachment <> "" Then
Set AttachME = MailDoc.CreateRichTextItem("ATTACHMENT")
Set EmbedObj = AttachME.embedobject(1454, "", strAttachment, "ATTACHMENT")
End If
'Signature or not
If intSignOption = 0 Then
MailDoc.body = strBody
Else
'Insert a Signature
Select Case intSignOption
Case 1: 'Plain text Signature
Set rtitem = MailDoc.CreateRichTextItem("Body")
Call rtitem.AppendText(strBody)
Call rtitem.AppendText(Chr(10)): Call rtitem.AppendText(Chr(10))
Call rtitem.AppendText(strSignText)
Case 2, 3: 'Document or Rich text
'Open memo in ui
Set uiMemo = ws.EditDocument(True, MailDoc)
Call uiMemo.GotoField("Body")
'Check if the signature is automatically inserted
If objProfile.GetItemValue("EnableSignature")(0) <> 1 Then
If intSignOption = 2 Then
Call uiMemo.Import(f_strSignatureType(strSignText), strSignText)
Else
Call uiMemo.ImportItem(objProfile, "Signature_Rich")
End If
End If
Call uiMemo.GotoField("Body")
'Save the mail doc
strMemoUNID = uiMemo.Document.UniversalID
uiMemo.Document.MailOptions = "0"
Call uiMemo.Save
uiMemo.Document.SaveOptions = "0"
Call uiMemo.Close
Set uiMemo = Nothing
Set MailDoc = Nothing
'Get the text and the signature
Set MailDoc = Maildb.GetDocumentByUNID(strMemoUNID)
Set rtiSig = MailDoc.GetFirstItem("Body")
Set rtiNew = MailDoc.CreateRichTextItem("rtiTemp")
Call rtiNew.AppendText(strBody)
Call rtiNew.AppendText(Chr(10)): Call rtiNew.AppendText(Chr(10))
Call rtiNew.AppendRTItem(rtiSig)
'Remove actual body to replace it with the new one
Call MailDoc.RemoveItem("Body")
Set rtitem = MailDoc.CreateRichTextItem("Body")
Call rtitem.AppendRTItem(rtiNew)
End Select
End If
MailDoc.Save False, False
Set uiMemo = ws.EditDocument(True, MailDoc)
f_SendNotesEmail = True
label_end:
Set Maildb = Nothing
Set MailDoc = Nothing
Set AttachME = Nothing
Set session = Nothing
Set EmbedObj = Nothing
Set rtitem = Nothing
Set uiMemo = Nothing
Set rtiSig = Nothing
Set rtiNew = Nothing
Set ws = Nothing
Exit Function
err_send:
f_SendNotesEmail = False
GoTo label_end
End Function
'---------------------------------------------------------------------------------------
' Procedure : f_strSignatureType
' Author : c159
' Date : 30/10/2012
' Purpose : Returns the Type of Import to do in Lotus
'---------------------------------------------------------------------------------------
'
Function f_strSignatureType(strFile As String) As String
Dim strExt As String
Dim i As Integer
strExt = ""
For i = Len(strFile) To 1 Step -1
If Mid(strFile, i, 1) = "." Then
strExt = UCase(Mid(strFile, i + 1))
Exit For
End If
Next i
Select Case strExt
Case "": f_strSignatureType = ""
Case "JPG": f_strSignatureType = "JPEG Image"
Case "JPEG": f_strSignatureType = "JPEG Image"
Case "BMP": f_strSignatureType = "BMP Image"
Case "GIF": f_strSignatureType = "GIF Image"
Case "HTM": f_strSignatureType = "HTM"
Case "HTML": f_strSignatureType = "HTM"
Case "TXT": f_strSignatureType = "ASCII"
End Select
End Function
'---------------------------------------------------------------------------------------
' Procedure : s_RecipientList
' Author : c159
' Date : 2014-03-20
' Purpose : Create the recipient list in an array
'---------------------------------------------------------------------------------------
'
Sub s_RecipientList(strArray() As String, strRecipientList As String)
Dim i As Integer, j As Integer
strRecipientList = Replace(strRecipientList, ";", ",")
If Right(strRecipientList, 1) <> "," Then strRecipientList = strRecipientList & ","
j = f_intChar_Count(strRecipientList, ",")
ReDim strArray(j)
For i = 1 To j
strArray(i) = f_strString_Extract(strRecipientList, ",", i)
Next i
End Sub |
Lotus 8.5 et VBA
Répondre avec citation
Partager