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
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
| && cdo2000.prg
#DEFINE cdoSendUsingMethod "http://schemas.microsoft.com/cdo/config … /sendusing"
#DEFINE cdoSendPassword "http://schemas.microsoft.com/cdo/config … ndpassword"
#DEFINE cdoSendUserName "http://schemas.microsoft.com/cdo/config … ndusername"
#DEFINE cdoSendUsingMethod "http://schemas.microsoft.com/cdo/config … /sendusing"
#DEFINE cdoSMTPAuthenticate "http://schemas.microsoft.com/cdo/config … thenticate"
#DEFINE cdoSMTPConnectionTimeout "http://schemas.microsoft.com/cdo/config … iontimeout"
#DEFINE cdoSMTPServer "http://schemas.microsoft.com/cdo/config … smtpserver"
#DEFINE cdoSMTPServerPort "http://schemas.microsoft.com/cdo/config … serverport"
#DEFINE cdoSMTPUseSSL "http://schemas.microsoft.com/cdo/config … smtpusessl"
#DEFINE cdoURLGetLatestVersion "http://schemas.microsoft.com/cdo/config … estversion"
#DEFINE cdoAnonymous 0 && Perform no authentication (anonymous)
#DEFINE cdoBasic 1 && Use the basic (clear text) authentication mechanism.
#DEFINE cdoSendUsingPort 2 && Send the message using the SMTP protocol over the network.
#DEFINE cdoXMailer "urn:schemas:mailheader:x-mailer"
DEFINE CLASS cdo2000 AS Custom
PROTECTED oErrors
oErrors = Null
&& Message attributes
PROTECTED oMsg
oMsg = Null
cFrom = ""
cReplyTo = ""
cTo = ""
cCC = ""
cBCC = ""
cAttachment = ""
cSubject = ""
cHtmlBody = ""
cTextBody = ""
cHtmlBodyUrl = ""
&& Configuration object fields values
PROTECTED oCfg
oCfg = Null
cServer = ""
nServerPort = 25
&& Use SSL connection
lUseSSL = .F.
nConnectionTimeout = 30 && Default 30 sec's
nAuthenticate = cdoAnonymous
cUserName = ""
cPassword = ""
&& Do not use cache for cHtmlBodyUrl
lURLGetLatestVersion = .T.
&& Optional. Creates your own X-MAILER field in the header
PROTECTED cXMailer
cXMailer = "VFP CDO 2000(CDOSYS) mailer Ver 1.0 2008"
PROTECTED PROCEDURE Init
&& Create error collection
This.oErrors = CREATEOBJECT("Collection")
ENDPROC
&& Send message
PROCEDURE Send
WITH This
.ClearErrors()
.oCfg = CREATEOBJECT("CDO.Configuration")
.oMsg = CREATEOBJECT("CDO.Message")
.oMsg.Configuration = This.oCfg
ENDWITH
&& Fill message attributes
LOCAL lnind, laList[1], loHeader, laDummy[1]
IF This.SetConfiguration() > 0
RETURN This.GetErrorCount()
ENDIF
IF EMPTY(This.cFrom)
This.AddError("ERROR : From is Empty.")
ENDIF
IF EMPTY(This.cSubject)
This.AddError("ERROR : Subject is Empty.")
ENDIF
IF EMPTY(This.cTo) AND EMPTY(This.cCC) AND EMPTY(cBCC)
This.AddError("ERROR : To,CC and BCC all are Empty.")
ENDIF
IF This.GetErrorCount() > 0
RETURN This.GetErrorCount()
ENDIF
This.SetHeader()
WITH This.oMsg
.From = This.cFrom
.ReplyTo = This.cReplyTo
.To = This.cTo
.CC = This.cCC
.BCC = This.cBCC
.Subject = This.cSubject
&& Create HTML body from external HTML (file, URL)
IF NOT EMPTY(This.cHtmlBodyUrl)
.CreateMHTMLBody(This.cHtmlBodyUrl)
ENDIF
&& Send HTML body. Creates TextBody as well
IF NOT EMPTY(This.cHtmlBody)
.HtmlBody = This.cHtmlBody
ENDIF
&& Send Text body. Could be different from HtmlBody, if any
IF NOT EMPTY(This.cTextBody)
.TextBody = This.cTextBody
ENDIF
&& Process attachments
IF NOT EMPTY(This.cAttachment)
&& Accepts comma, semicolon
FOR lnind=1 TO ALINES(laList, This.cAttachment, [,], [;])
lcAttachment = ALLTRIM(laList[lnind])
&& Ignore empty values
IF EMPTY(laList[lnind])
LOOP
ENDIF
&& Make sure that attachment exists
IF ADIR(laDummy, lcAttachment) = 0
This.AddError("ERROR: Attacment not Found - " + lcAttachment)
ELSE
&& The full path is required.
IF UPPER(lcAttachment) <> UPPER(FULLPATH(lcAttachment))
lcAttachment = FULLPATH(lcAttachment)
ENDIF
.AddAttachment(lcAttachment)
ENDIF
ENDFOR
ENDIF
ENDWITH
IF This.GetErrorCount() > 0
RETURN This.GetErrorCount()
ENDIF
TRY
This.oMsg.Send()
CATCH TO oErr
This.AddOneError("SEND ERROR: ", oErr.ErrorNo, oErr.procedure, oErr.LineNo)
ENDTRY
RETURN This.GetErrorCount()
ENDPROC
&& Clear error collection
PROCEDURE ClearErrors()
RETURN This.oErrors.Remove(-1)
ENDPROC
&& Return # of errors in the error collection
PROCEDURE GetErrorCount
RETURN This.oErrors.Count
ENDPROC
&& Return error by index
PROCEDURE GetError(tnErrorno)
IF tnErrorno <= This.GetErrorCount()
RETURN This.oErrors.Item(tnErrorno)
ELSE
RETURN Null
ENDIF
ENDPROC
&& Populate configuration object
PROTECTED PROCEDURE SetConfiguration
&& Validate supplied configuration values
IF EMPTY(This.cServer)
This.AddError("ERROR: SMTP Server isn't specified.")
ENDIF
IF NOT INLIST(This.nAuthenticate, cdoAnonymous, cdoBasic)
This.AddError("ERROR: Invalid Authentication protocol ")
ENDIF
IF This.nAuthenticate = cdoBasic ;
AND (EMPTY(This.cUserName) OR EMPTY(This.cPassword))
This.AddError("ERROR: User name/Password is required for basic authentication")
ENDIF
IF This.GetErrorCount() > 0
RETURN This.GetErrorCount()
ENDIF
WITH This.oCfg.Fields
&& Send using SMTP server
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = This.cServer
.Item(cdoSMTPServerPort) = This.nServerPort
.Item(cdoSMTPConnectionTimeout) = This.nConnectionTimeout
.Item(cdoSMTPAuthenticate) = This.nAuthenticate
IF This.nAuthenticate = cdoBasic
.Item(cdoSendUserName) = This.cUserName
.Item(cdoSendPassword) = This.cPassword
ENDIF
.Item(cdoURLGetLatestVersion) = This.lURLGetLatestVersion
.Item(cdoSMTPUseSSL) = This.lUseSSL
.Update()
ENDWITH
RETURN This.GetErrorCount()
ENDPROC
&&----------------------------------------------------
&& Add message to the error collection
PROTECTED PROCEDURE AddError(tcErrorMsg)
RETURN This.oErrors.Add(tcErrorMsg)
ENDPROC
&&----------------------------------------------------
&& Format an error message and add to the error collection
PROTECTED PROCEDURE AddOneError(tcPrefix, tnError, tcMethod, tnLine )
LOCAL lcErrorMsg, laList[1]
IF INLIST(tnError, 1427,1429)
AERROR(laList)
lcErrorMsg = TRANSFORM(laList[7], "@0") + ;
" " + laList[4] + " " + laList[3]
ELSE
lcErrorMsg = MESSAGE()
ENDIF
This.AddError(tcPrefix + ":" + TRANSFORM(tnError) + " # " + ;
tcMethod + " # " + TRANSFORM(tnLine) + " # " + lcErrorMsg)
RETURN This.oErrors.Count
ENDPROC
&&----------------------------------------------------
&& Simple Error handler. Adds VFP error to the objects error collection
PROTECTED PROCEDURE Error(tnError, tcMethod, tnLine)
&&!* This.AddError("VFP Error: " + TRANSFORM(tnError) + " # " + ;
&&!* tcMethod + " # " + TRANSFORM(tnLine) + " # " + MESSAGE())
This.AddOneError("ERROR: ", tnError, tcMethod, tnLine )
RETURN This.oErrors.Count
ENDPROC
&&-------------------------------------------------------
&& Set mail header fields, if necessary. For now sets X-MAILER, if specified
PROTECTED PROCEDURE SetHeader
LOCAL loHeader
IF NOT EMPTY(This.cXMailer)
loHeader = This.oMsg.Fields
WITH loHeader
.Item(cdoXMailer) = This.cXMailer
.Update()
ENDWITH
ENDIF
ENDPROC
ENDDEFINE |