>.
Va rugam sa listati facturile si sa le inregistrati in contabilitate.
De asemenea, va rugam sa dati un reply la acest email pentru confirmarea primirii facturilor.
--
Cu stima,
ENDTEXT
lcBodyFileSchema = goApp.ReadIni('email_factura', 'bodyfile_borderou_' + m.gcS) && bodyfile_ACN
lcBodyFileGeneral = goApp.ReadIni('email_factura', 'bodyfile_borderou')
lcBodyFile = Iif(!Empty(m.lcBodyFileSchema), m.lcBodyFileSchema, m.lcBodyFileGeneral)
lcBodyBorderouContent = ''
If Empty(m.lcBodyFile) Or !File(m.lcBodyFile)
If AMESSAGEBOX('Doriti sa creati un fisier pentru continutul emailului borderou (DA) sau sa alegeti un fisier (NU)?', 4 + 32, _Screen.Caption) = 6
lcBodyFile = Putfile('Fisier continut email', 'borderou_emailbody.html', 'html')
If !Empty(m.lcBodyFile)
Strtofile(m.lcBodyContentTemplate, m.lcBodyFile)
Endif
Else
lcBodyFile = Getfile('HTML', 'Alegeti fisierul continut email:', 'Alege', 1, 'Continut email')
Endif
goApp.WriteIni('email_factura', 'bodyfile_borderou', m.lcBodyFile)
Endif
If File(m.lcBodyFile)
lcBodyBorderouContent = Filetostr(m.lcBodyFile)
Endif
If Empty(m.lcBodyContent)
lcBodyBorderouContent = m.lcBodyContentTemplate
Endif
**********
lcEmailFromSchema = goApp.ReadIni('email_factura', 'from_' + m.gcS)
lcEmailFromGeneral = goApp.ReadIni('email_factura', 'from')
lcEmailFrom = Iif(!Empty(m.lcEmailFromSchema), m.lcEmailFromSchema, m.lcEmailFromGeneral)
If Empty(m.lcEmailFrom )
goApp.WriteIni('email_factura', 'from_' + m.gcS, 'test@server.ro')
Endif
lcEmailFromNameSchema = goApp.ReadIni('email_factura', 'from_name_' + m.gcS)
lcEmailFromNameGeneral = goApp.ReadIni('email_factura', 'from_name')
lcEmailFromName = Iif(!Empty(m.lcEmailFromNameSchema), m.lcEmailFromNameSchema, m.lcEmailFromNameGeneral)
If Empty(m.lcEmailFromName)
goApp.WriteIni('email_factura', 'from_name_' + m.gcS, '')
Endif
lcEmailCCSchema = goApp.ReadIni('email_factura', 'cc_' + m.gcS)
lcEmailCCGeneral = goApp.ReadIni('email_factura', 'cc')
lcEmailCC = Iif(!Empty(m.lcEmailCCSchema), m.lcEmailCCSchema, m.lcEmailCCGeneral)
If Empty(m.lcEmailCC )
goApp.WriteIni('email_factura', 'cc_' + m.gcS, '')
Endif
lcEmailBCCSchema = goApp.ReadIni('email_factura', 'bcc_' + m.gcS)
lcEmailBCCGeneral = goApp.ReadIni('email_factura', 'bcc')
lcEmailBCC = Iif(!Empty(m.lcEmailBCCSchema), m.lcEmailBCCSchema, m.lcEmailBCCGeneral)
If Empty(m.lcEmailBCC )
goApp.WriteIni('email_factura', 'bcc_' + m.gcS, '')
Endif
lcSubjectTemplateSchema = goApp.ReadIni('email_factura', 'subject_' + m.gcS)
lcSubjectTemplateGeneral = goApp.ReadIni('email_factura', 'subject')
lcSubjectTemplate = Iif(!Empty(m.lcSubjectTemplateSchema), m.lcSubjectTemplateSchema, m.lcSubjectTemplateGeneral)
If Empty(m.lcSubjectTemplate)
lcSubjectTemplate = 'Factura '
goApp.WriteIni('email_factura', 'subject', m.lcSubjectTemplate)
Endif
***********
lcSubjectTemplateSchema = goApp.ReadIni('email_factura', 'subject_boderou_' + m.gcS)
lcSubjectTemplateGeneral = goApp.ReadIni('email_factura', 'subject_borderou')
lcSubjectBorderouTemplate = Iif(!Empty(m.lcSubjectTemplateSchema), m.lcSubjectTemplateSchema, m.lcSubjectTemplateGeneral)
If Empty(m.lcSubjectBoderouTemplate)
lcSubjectBoderouTemplate = 'Borderou facturi nr. din - '
goApp.WriteIni('email_factura', 'subject_borderou', m.lcSubjectBoderouTemplate)
Endif
***********
lcPreview = Alltrim(goApp.ReadIni('email_factura', 'preview'))
If Empty(m.lcPreview)
lcPreview = "1"
goApp.WriteIni('email_factura', 'preview', m.lcPreview)
Endif
llPreview = (m.lcPreview = "1")
lcWait = Alltrim(goApp.ReadIni('email_factura', 'wait'))
If Empty(m.lcWait)
lcWait = "0"
goApp.WriteIni('email_factura', 'wait', m.lcWait)
Endif
llWait = (m.lcWait = "1")
* Display the email window if empy(to, cc, subject) or return error
lcDisplayWithoutInfo = Alltrim(goApp.ReadIni('email_factura', 'display_without_info'))
If Empty(m.lcDisplayWithoutInfo)
lcDisplayWithoutInfo = "0"
goApp.WriteIni('email_factura', 'display_without_info', m.lcDisplayWithoutInfo)
Endif
llDisplayWithoutInfo = (m.lcDisplayWithoutInfo = "1")
* Send email without attachments or return error
lcSendWithoutAttachments = Alltrim(goApp.ReadIni('email_factura', 'send_without_attachments'))
If Empty(m.lcSendWithoutAttachments)
lcSendWithoutAttachments = "0"
goApp.WriteIni('email_factura', 'send_without_attachments', m.lcSendWithoutAttachments)
Endif
llSendWithoutAttachments = (m.lcSendWithoutAttachments = "1")
lcEmailHtml = goApp.ReadIni('email_factura', 'html')
If Empty(m.lcEmailHtml )
goApp.WriteIni('email_factura', 'html', '1')
Endif
lcEmailServer = goApp.ReadIni('email', 'mailserver')
If Empty(m.lcEmailServer)
goApp.WriteIni('email', 'mailserver', 'test.server.ro')
Endif
lcEmailPort = goApp.ReadIni('email', 'port')
If Empty(m.lcEmailPort)
goApp.WriteIni('email', 'port', '25')
Endif
lnEmailPort = Int(Val(m.lcEmailPort))
lcEmailUserName = goApp.ReadIni('email', 'username')
If Empty(m.lcEmailUserName)
goApp.WriteIni('email', 'username', 'test')
Endif
lcEmailPassword = goApp.ReadIni('email', 'password')
If Empty(m.lcEmailPassword )
goApp.WriteIni('email', 'password', 'test')
Endif
lcEmailSSL = goApp.ReadIni('email', 'ssl')
If Empty(m.lcEmailSSL)
goApp.WriteIni('email', 'ssl', '0')
Endif
llEmailSSL = Int(Val(m.lcEmailSSL))
lcExePath = goApp.ReadIni('email', 'exepath')
If Empty(m.lcExePath)
goApp.WriteIni('email', 'exepath', '')
Endif
Do Case
Case m.lcEmailMode = 'THUNDERBIRDCMD'
loMail = Newobject("oThunderbirdEmailCMD", "email.fxp")
Case m.lcEmailMode = 'OUTLOOK'
loMail = Newobject("oOutlook", "email.fxp")
Case m.lcEmailMode = 'MAPI'
loMail = Newobject("oMapi", "email.fxp")
Otherwise
loMail = Newobject("oCDO", "email.fxp")
Endcase
**************************
* CDO Specific
loMail.cServer = m.lcEmailServer
loMail.nServerPort = m.lnEmailPort
loMail.cUserName = m.lcEmailUserName
loMail.cPassword = m.lcEmailPassword
loMail.lUseSSL = m.llEmailSSL
loMail.nAuthenticate = Iif(Empty(loMail.cUserName), 0, 1)
**************************
* Thunderbird Specific
loMail.EmailSetExePath(m.lcExePath)
loMail.EmailSetWait(m.llWait) && wait and dont't advance to the next email until send is pressed
**************************
**************************
* Outlook Specific
loMail.EmailSetPreview(m.llPreview)
loMail.EmailSetDisplayWithoutInfo(m.llDisplayWithoutInfo)
**************************
loMail.cFrom = m.lcEmailFrom
loMail.cFromName = m.lcEmailFromName
loMail.cCC = m.lcEmailCC
loMail.cBCC = m.lcEmailBCC
loMail.cSubject = m.lcSubjectTemplate
loMail.cHtmlBody = m.lcBodyContent
loMail.cBorderouSubject = m.lcSubjectBorderouTemplate
loMail.cBorderouBody = m.lcBodyBorderouContent
loMail.EmailSendWithoutAttachments(m.llSendWithoutAttachments)
Return loMail
Endproc && getoEmail
* -----------------------------------
* oEmail.Send
* > EmailSend
* >> EmailCreateCfg
* >> EmailSetConfiguration
* >> EmailSetHeader
* >> EmailSetParameters
Define Class oEmail As Custom
Protected aErrors[1], nErrorCount, oMsg, oCfg, cXMailer
nErrorCount = 0
* Message attributes
oMsg = Null
cFrom = ""
cFromName = ""
cReplyTo = ""
cTo = ""
cCC = ""
cBCC = ""
cAttachment = "" && attachment file list separated by comma
nAttachments = 0 && number of attachment files
cSubject = "" && subiect email factura
cHtmlBody = "" && continut email factura
cTextBody = ""
cHtmlBodyUrl = ""
cBorderouSubject = "" && subiect email borderou
cBorderouBody = "" && continut email borderou
cCharset = ""
* Priority: Normal, High, Low or empty value (Default)
cPriority = ""
* Configuration object fields values
oCfg = Null
cServer = ""
nServerPort = 25
* Use SSL connection
lUseSSL = .F.
nConnectionTimeout = 30 && Default 30 sec's
nAuthenticate = oAnonymous
cUserName = ""
cPassword = ""
* Do not use cache for cHtmlBodyUrl
lURLGetLatestVersion = .T.
* Optional. Creates your own X-MAILER field in the header
cXMailer = ""
cEmailExePath = ''
cEmailProfile = ''
lEmailWait = .F. && wait for the email to be sent, to advance to the next email
lEmailPreview = .F. && preview each mail (default .F.)
lDisplayEmailWithoutInfo = .F. && display mail without from, to, subject, body, attachment
lCanDisplayEmailWithoutInfo = .T. && can the email without from, to, subject, body be displayed to user? (CDO does not display anything, for now)
lFirstEmail = .T. && after the first email becomes .F., in case you want to do some things only the first time (eg: show the Sent folder in Outlook)
lSendWithoutAttachments = .F. && if email can be sent without attachment (Default = .F.)
lReadReceipt = .T. && confirmare de citire
lPriority = .F. && prioritate
Protected Procedure Init
This.ClearErrors()
Endproc
* Send message
* Return Number of Errors (0 = succes)
Procedure Send
Local lnErrorCount
lnErrorCount = This.GetErrorCount()
If m.lnErrorCount > 0
This.ClearMessage()
Return m.lnErrorCount
Endif
With This
.ClearErrors()
.EmailCreateCfg() && abstract, to be implemented
Endwith
* Check server, user, password
lnErrorCount = This.SetConfiguration()
If m.lnErrorCount = 0
* If email without info doesn't display to the user, add error
If !(This.lDisplayEmailWithoutInfo And This.lCanDisplayEmailWithoutInfo)
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(This.cBCC)
* This.AddError("ERROR : To, CC and BCC are all empty.")
* Nu permit trimiterea de emailuri (cu facturi) fara TO.
* Altfel le trimite doar la CC/BCC, adica trimite copia inapoi.
* CC/BCC sunt fixe in settings.ini si nu ma intereseaza daca sunt sau nu completate
This.AddError("ERROR : To is empty.")
Endif
Endif
Endif && SetConfiguration
lnErrorCount = This.GetErrorCount()
If m.lnErrorCount = 0
This.EmailSetHeader()
This.EmailSetParameters()
Endif
lnErrorCount = This.GetErrorCount()
If m.lnErrorCount = 0
This.AddAttachments()
* If email without attachment doesn't display to the user, add error
If !(This.lDisplayEmailWithoutInfo And This.lCanDisplayEmailWithoutInfo)
If !This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber())
This.AddError("ERROR : There are no attachments.")
Endif
Endif
Endif
* Send Email
lnErrorCount = This.GetErrorCount()
If m.lnErrorCount = 0
This.EmailSend()
lnErrorCount = This.GetErrorCount()
Endif
This.lFirstEmail = .F.
This.ClearMessage()
Return m.lnErrorCount
Endproc
* Clear errors collection
Procedure ClearErrors()
This.nErrorCount = 0
Dimension This.aErrors[1]
This.aErrors[1] = Null
Return This.nErrorCount
Endproc
* Return # of errors in the error collection
Procedure GetErrorCount
Return This.nErrorCount
Endproc
* Return error by index
Procedure Geterror
Lparameters tnErrorno
If tnErrorno <= This.GetErrorCount()
Return This.aErrors[tnErrorno]
Else
Return Null
Endif
Endproc
* Return all error messages into one message
Procedure GetErrorMessage
Lparameters tlClearErrors
* tlClearErrors (optional): clear all error messages
Local lcErrorMessage, lnError, lnErrors
lnErrors = This.GetErrorCount()
lcErrorMessage = ''
For lnError = 1 To m.lnErrors
lcErrorMessage = m.lcErrorMessage + This.Geterror(m.lnError) + '***'
Endfor
* Clear errors
If m.tlClearErrors
This.ClearErrors()
Endif
Return m.lcErrorMessage
Endproc && GetErrorMessage
* 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, oAnonymous, oBasic)
This.AddError("ERROR: Invalid Authentication protocol ")
Endif
If This.nAuthenticate = oBasic ;
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
* Populate configuration objects
This.EmailSetConfiguration()
Return This.GetErrorCount()
Endproc
*----------------------------------------------------
* Add message to the error collection
Protected Procedure AddError
Lparameters tcErrorMsg
This.nErrorCount = This.nErrorCount + 1
Dimension This.aErrors[This.nErrorCount]
This.aErrors[This.nErrorCount] = tcErrorMsg
Return This.nErrorCount
Endproc
*----------------------------------------------------
* Format an error message and add to the error collection
Protected Procedure AddOneError
Lparameters tcPrefix, tnError, tcMethod, tnLine
Local lcErrorMsg, laList[1]
If Inlist(tnError, 1427, 1429)
Aerror(laList)
lcErrorMsg = Transform(laList[7], "@0") + " " + laList[3]
Else
lcErrorMsg = Message()
Endif
This.AddError(tcPrefix + ":" + Transform(tnError) + " # " + ;
tcMethod + " # " + Transform(tnLine) + " # " + lcErrorMsg)
Return This.nErrorCount
Endproc
*----------------------------------------------------
* Simple Error handler. Adds VFP error to the objects error collection
Protected Procedure Error
Lparameters tnError, tcMethod, tnLine
This.AddOneError("ERROR: ", tnError, tcMethod, tnLine )
Return This.nErrorCount
Endproc
Procedure EmailSetProfile
Lparameters tcProfile
This.cEmailProfile = m.tcProfile
Endproc
Procedure EmailSetExePath
Lparameters tcExePath
This.cEmailExePath = m.tcExePath
Endproc
Procedure EmailSetWait
Lparameters tlWait
This.lEmailWait = m.tlWait
Endproc && EmailSetWait
*-------------------------------------------------------
* Add a file to the attachement list
Procedure EmailSetAttachment
Lparameters tcFile
If !Empty(m.tcFile) And Type('tcFile') = 'C'
This.cAttachment = This.cAttachment + Iif(!Empty(This.cAttachment), ",", "") + m.tcFile
Endif
Endproc && SetAttachment
*-------------------------------------------------------
* Overwrite the attachement list with a list of files
Procedure EmailSetAttachments
Lparameters tcFiles
If !Empty(m.tcFiles) And Type('tcFiles') = 'C'
This.cAttachment = m.tcFiles
Endif
Endproc && SetAttachment
*-------------------------------------------------------
* Empty the recipient list in subclass
Procedure EmailClearMessage
* To be implemented
Endproc && EmailClearMessage
Procedure ClearMessage
This.EmailClearMessage()
This.cTo = ""
This.cHtmlBody = ""
This.cSubject = ""
This.cAttachment = ""
Endproc && ClearMessage
Procedure EmailSendWithoutAttachments
Lparameters tlSendWithoutAttachments
This.lSendWithoutAttachments = m.tlSendWithoutAttachments
Endproc
Procedure AddAttachments
Local laList[1], laDummy[1]
Local lcAttachment, lnAttachment, lnAttachments
* Process attachments
If Not Empty(This.cAttachment)
* Accepts comma or semicolon
lnAttachments = Alines(laList, This.cAttachment, [,], [;])
For lnAttachment = 1 To m.lnAttachments
lcAttachment = Alltrim(laList[m.lnAttachment])
* Ignore empty values
If Empty(laList[m.lnAttachment])
Loop
Endif
* Make sure that attachment exists
If Adir(laDummy, lcAttachment) = 0
This.AddError("ERROR: Attachment not Found - " + lcAttachment)
Else
* The full path is required.
If Upper(lcAttachment) <> Upper(Fullpath(lcAttachment))
lcAttachment = Fullpath(lcAttachment)
Endif
This.EmailAddAttachment(lcAttachment)
Endif
Endfor
Endif
Endproc && AddAttachments
Procedure EmailAddAttachment
Lparameters tcAttachment
* To be implemented
Endproc && EmailAddAtachment
Procedure EmailGetAttachmentsNumber
Return Getwordcount(This.cAttachment, [,])
Endproc
Procedure EmailSetPreview
Lparameters tlSetPreview
This.lEmailPreview = m.tlSetPreview
Endproc && EmailSetPreview
Procedure EmailSetDisplayWithoutInfo
Lparameters tlSetDisplay
This.lDisplayEmailWithoutInfo = m.tlSetDisplay
Endproc && EmailSetDisplayWithoutInfo
*-------------------------------------------------------
* Create configuration objects
Procedure EmailCreateCfg
* to be implemented
Endproc
*-------------------------------------------------------
* Set mail header fields, if necessary. For now sets X-MAILER, if specified
Procedure EmailSetHeader
* to be implemented
Endproc
*-------------------------------------------------------
* Set to, from, atachments..
Procedure EmailSetParameters
* to be implemented
Endproc
*-------------------------------------------------------
* Set server, username, password
* Return Number of Errors (0 = success)
Procedure EmailSetConfiguration()
* to be implemented
Return 0
Endproc
*-------------------------------------------------------
* Send email
Procedure EmailSend
* to be implemented
Endproc
*-------------------------------------------------------
* Add Error
Procedure EmailAddError
Lparameters tcErrorMessage
This.AddError("ERROR : " + Transform(m.tcErrorMessage))
Endproc
*----------------------------------------------------
*
Protected Procedure cPriority_assign(tvVal)
* Check for incorrect values
If Inlist("~" + Proper(tvVal) + "~", "~High~", "~Normal~", "~Low~") Or Empty(tvVal)
This.cPriority = Proper(Alltrim(tvVal))
Else
This.AddError("ERROR: Invalid value for cPriority property.")
Endif
Endproc
Enddefine && oEmail
*-----------------------------------------------------------
*!* oEmail.Send
*!* > EmailCreateCfg
*!* > EmailSetConfiguration
*!* > EmailSetHeader
*!* > EmailSetParameters
*!* > EmailSend
Define Class oThunderbirdEmailCmd As oEmail
Procedure EmailSend
Local loRun As 'api_apprun' Of 'process.vcx'
Local lcBody, lcCommandLine, lcExePath, lcProfile
lcProfile = This.cEmailProfile
lcExePath = This.cEmailExePath
lcBody = Iif(!Empty(This.cHtmlBody), This.cHtmlBody, This.cTextBody)
If Empty(This.cHtmlBody)
lcBody = Strtran(m.lcBody, Chr(13) + Chr(10), [
], 1, 1000, 1)
lcBody = Strtran(m.lcBody, Chr(13), [
], 1, 1000, 1)
Else
lcBody = Strtran(m.lcBody, Chr(13) + Chr(10), [], 1, 1000, 1)
lcBody = Strtran(m.lcBody, Chr(13), [], 1, 1000, 1)
Endif
lcBody = Strtran(m.lcBody, [,], [,], 1, 1000, 1)
lcCommandLine = ["] + m.lcExePath + ["] + ;
IIF(!Empty(m.lcProfile), [-profile "] + m.lcProfile + ["], []) + ;
[ -compose ] + ;
IIF(!Empty(This.cFrom), [from="] + This.cFrom + ["], []) + ;
IIF(!Empty(This.cTo), [,to="] + This.cTo + ["], []) + ;
IIF(!Empty(This.cCC), [,cc="] + This.cCC + ["], []) + ;
IIF(!Empty(This.cBCC), [,bcc="] + This.cBCC + ["], []) + ;
IIF(!Empty(This.cSubject), [,subject="] + This.cSubject + ["], []) + ;
IIF(!Empty(m.lcBody), [,body="] + m.lcBody + ["], []) + ;
IIF(!Empty(This.cAttachment), [,attachment='] + This.cAttachment + ['], [])
If !'process.vcx' $ Lower(Set("Classlib"))
Set Classlib To 'D:\ROA\ROAACNPRO\COMUN\clase\process.vcx' Additive
Endif
loRun = Createobject('api_apprun')
If File (m.lcExePath)
loRun.iccommandline = m.lcCommandLine
If This.lEmailWait
loRun.launchappandwait()
Else
loRun.launchapp()
Endif
Else
This.EmailAddError('Thunderbird exe path ' + m.lcExePath + ' does not exist!')
Endif
Endproc && EmailSend
Enddefine && ThunderbirdEmailCMD
*-----------------------------------------------------------
*!* oEmail.Send
*!* > EmailCreateCfg
*!* > EmailSetConfiguration
*!* > EmailSetHeader
*!* > EmailSetParameters
*!* > EmailSend
Define Class oCDO As oEmail
Protected oMsg, oCfg
* Message attributes
oMsg = Null
* Configuration object fields values
oCfg = Null
Procedure Init
DoDefault()
Local loEx As Exception
This.lCanDisplayEmailWithoutInfo = .T.
* Optional. Creates your own X-MAILER field in the header
This.cXMailer = "VFP CDO 2000 mailer Ver 1.1.100 2010"
Endproc
*-------------------------------------------------------
Procedure EmailCreateCfg
Local loEx As Exception
Try
This.oMsg = Createobject("CDO.Message")
This.oCfg = Createobject("CDO.Configuration")
This.oMsg.Configuration = This.oCfg
Catch To loEx
This.AddError('ERROR: CDO Configuration could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message)
Endtry
Endproc
*-------------------------------------------------------
* Populate configuration object
Procedure EmailSetConfiguration
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
Endproc
*-------------------------------------------------------
* Set mail header fields, if necessary. For now sets X-MAILER, if specified
Procedure EmailSetHeader
Local loHeader
If Not Empty(This.cXMailer)
loHeader = This.oMsg.Fields
With loHeader
.Item(cdoXMailer) = This.cXMailer
.Update()
Endwith
Endif
Endproc
*-------------------------------------------------------
Procedure EmailSetParameters
* Fill message attributes
Local lcMailHeader
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
If Not Empty(This.cCharset)
If Not Empty(.HtmlBody)
.HtmlBodyPart.Charset = This.cCharset
Endif
If Not Empty(.TextBody)
.TextBodyPart.Charset = This.cCharset
Endif
Endif
If Not Empty(This.cCharset)
.BodyPart.Charset = This.cCharset
Endif
* Priority
If Not Empty(This.cPriority)
lcMailHeader = "urn:schemas:mailheader:"
.Fields(lcMailHeader + "Priority") = Lower(This.cPriority)
.Fields(lcMailHeader + "Importance") = Lower(This.cPriority)
Do Case
Case This.cPriority = "High"
.Fields(lcMailHeader + "X-Priority") = 1 && 5=Low, 3=Normal, 1=High
Case This.cPriority = "Normal"
.Fields(lcMailHeader + "X-Priority") = 3 && 5=Low, 3=Normal, 1=High
Case This.cPriority = "Low"
.Fields(lcMailHeader + "X-Priority") = 5 && 5=Low, 3=Normal, 1=High
Endcase
.Fields.Update()
ENDIF
* by CChalom - Codes included to allow Receipt return and Priority
* http://support.microsoft.com/kb/302839
IF This.lReadReceipt = .T.
This.oMsg.Fields("urn:schemas:mailheader:disposition-notification-to") = This.cTo
This.oMsg.Fields("urn:schemas:mailheader:return-receipt-to") = This.cTo
This.oMsg.Fields.Update()
ENDIF
* Set priority if needed
IF This.lPriority
This.oMsg.Fields("Priority").Value = 1 && -1=Low, 0=Normal, 1=High
This.oMsg.Fields.Item("urn:schemas:mailheader:X-Priority") = 1 && -1=Low, 0=Normal, 1=High
This.oMsg.Fields.Item("urn:schemas:httpmail:importance") = 1
This.oMsg.Fields.Update()
ENDIF
Endwith
Endproc
Procedure EmailAddAttachment
Lparameters tcAttachment
This.oMsg.AddAttachment(m.tcAttachment)
Endproc
*------------------------------
Procedure EmailClearMessage
This.oMsg = Null
This.oCfg = Null
Endproc && EmailClearMessage
*----------------------------------------------------
* Send message
Procedure EmailSend
SET STEP ON
* Daca nu sunt completate toate informatiile arat emailul utilizatorului
Local _goFP As "PreviewHelper"
Local llCancelled, llEmailDisplay, llEmailPreview, lnError, lcFoxy, lcDirMare, llCancelled
LOCAL loEx as Exception
llEmailDisplay = This.lDisplayEmailWithoutInfo And (Empty(This.cTo) Or Empty(This.cSubject) Or (!This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber())))
llEmailPreview = This.lEmailPreview
&& Daca nu arat fiecare email, il trimit automat
If !(m.llEmailPreview Or m.llEmailDisplay)
If This.oMsg.Send() > 0
For lnError = 1 To This.oMsg.GetErrorCount()
This.AddError(This.oMsg.Geterror(m.lnError))
Endfor
Endif
Else
TRY
lcDirMare = Addbs(Left(m.gcAppPath, Rat("\", m.gcAppPath, 2) -1))
lcFoxy = m.lcDirMare + 'COMUNROA\foxypreviewer.app'
IF FILE(m.lcFoxy)
Do (m.lcFoxy)
_goFP = Createobject("PreviewHelper")
With This
*_goFP.cdestFile = m.lcImageFile
*!* m.loExHandler = Newobject('ExtensionHandler')
*!* _goFP._oExHandler = m.loExHandler
_goFP.lemailAUTO = .F.
_goFP.cemailTo = .cTO
_goFP.cemailCC = .cCC
_goFP.cemailBCC = .cBCC
_goFP.cemailSubject = .cSubject
_goFP.cEmailBody = .cHtmlBody
_goFP.cAttachments = This.cAttachment
ENDWITH
llCancelled = .F.
Do Form pr_sendmail2.scx To m.llCancelled Name _goFP._oEmailSheet
IF m.llCancelled
This.AddError('CDO Email Preview Utilizatorul a anulat emailul')
ELSE
With This
.cTo = _goFP.cemailTo && "vfpimaging@hotmail.com" && "somebody@otherdomain.com, somebodyelse@otherdomain.com"
.cCC = _goFP.cEmailCC
.cBCC = _goFP.cEmailBCC
.cSubject = _goFP.cemailSubject && "FOXYPREVIEWER email"
.cReplyTo = _goFP.cEmailReplyTo
If Empty(_goFP.cEmailBody)
_goFP.cEmailBody = "
"
Endif
If Upper(Left(_goFP.cEmailBody, 6)) == ""
.cHtmlBody = _goFP.cEmailBody
Else
.cTextBody = _goFP.cEmailBody
Endif
* Curat lista de atasamente anterioara si adaug atasamentele din formular
.cAttachment = _goFP._cAttachment
.lReadReceipt = _goFP.lReadReceipt
.lPriority = _goFP.lPriority
Endwith
This.EmailSetParameters()
This.oMsg.Attachments.DeleteAll()
This.AddAttachments()
If This.oMsg.Send() > 0
For lnError = 1 To This.oMsg.GetErrorCount()
This.AddError(This.oMsg.Geterror(m.lnError))
Endfor
ENDIF
ENDIF && llCancelled
ELSE
This.AddError('CDO Email Preview ' + m.lcFoxy + ' nu exista' + ' ' + loEx.Message + ' Linia: ' + TRANSFORM(loEx.Lineno) + ' Cod: ' + loEx.LineContents)
ENDIF && FILE(m.lcFoxy)
Catch To loEx
This.AddError('CDO Email Preview ' + ' ' + loEx.Message + ' Linia: ' + TRANSFORM(loEx.Lineno) + ' Cod: ' + loEx.LineContents)
*Messagebox(loEx.Message, 0 + 48, _Screen.Caption)
Endtry
Endif && m.llEmailPreview Or m.llEmailDisplay
Endproc && EmailSend
Enddefine && oCDO
Define Class oOutlook As oEmail
oOutlook = Null
oMailItem = Null
Procedure Init
DoDefault()
Local loEx As Exception
Try
This.oOutlook = Createobject('outlook.application')
Catch To loEx
This.AddError('ERROR: OUTLOOK could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message)
Endtry
Endproc && Init
************************************
Procedure EmailCreateCfg
Local loEx As Exception
If !Isnull(This.oOutlook)
Try
* Create Mail Item
This.oMailItem = This.oOutlook.CreateItem(0)
Catch To loEx
This.AddError('ERROR: OUTLOOK MailItem could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message)
Endtry
Endif
Endproc && EmailCreateCfg
************************************
Procedure EmailSetParameters
Local lcAttachment, lnAttachment
With This.oMailItem
.To = This.cTo
.Subject = This.cSubject
.CC = This.cCC
.BCC = This.cBCC
.BodyFormat = olFormatHTML
.HtmlBody = This.cHtmlBody
Endwith
Endproc && EmailSetParameters
Procedure EmailAddAttachment
Lparameters tcAttachment
This.oMailItem.Attachments.Add(m.tcAttachment)
Endproc
*------------------------------
Procedure EmailClearMessage
This.oMailItem = Null
Endproc && EmailClearMessage
*------------------------------
Procedure EmailSend
Local llEmailDisplay, llEmailPreview, loDefaultFolder, loMailItem, loNameSpace
loMailItem = This.oMailItem
* Display Sent folder only for the first email, so that the emails will get send
If This.lFirstEmail
loNameSpace = This.oOutlook.getnamespace('MAPI')
loDefaultFolder = loNameSpace.GetDefaultFolder(olFolderSentMail) && SentMail
loDefaultFolder.Display()
Endif
* Daca nu sunt completate toate informatiile arat emailul utilizatorului
llEmailDisplay = This.lDisplayEmailWithoutInfo And (Empty(This.cTo) Or Empty(This.cSubject) Or (!This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber())))
llEmailPreview = This.lEmailPreview
&& Daca nu arat fiecare email, il trimit automat
If m.llEmailPreview Or m.llEmailDisplay
loMailItem.Display
Else
loMailItem.Send
Endif
This.oMailItem = Null
loMailItem = ""
Endproc && EmailSend
Enddefine &&oOutlook
*---------------------------------
Define Class oMapi As oEmail
snd = .F.
rcp = .F.
att = .F.
*-------------------------------------------------------
Procedure EmailCreateCfg
Local loEx As Exception
Try
This.snd = Createobject("TRecipients")
This.rcp = Createobject("TRecipients")
This.att = Createobject("TAttachments")
Catch To loEx
This.AddError('ERROR: Mapi Configuration could not be instantiated ' + Transform(loEx.ErrorNo) + ' ' + loEx.Message)
Endtry
Endproc
*-------------------------------------------------------
Procedure EmailSetParameters
Local lcRecipient, lnRecipient, lnRecipients
This.AddSender(This.cFromName, This.cFrom)
This.AddRecipient(This.cTo, MAPI_TO)
This.AddRecipient(This.cCC, MAPI_CC)
This.AddRecipient(This.cBCC, MAPI_BCC)
Endproc
Procedure AddSender(lcSndName, lcSndAddr)
Local lnClass
lnClass = MAPI_ORIG
If Type("lcSndAddr") <> "C"
lcSndAddr = lcSndName
Endif
This.snd.AppendItem(m.lnClass, lcSndName, lcSndAddr)
Endproc && AddSender
* ---------------------------
* Fill To, CC, BCC
Procedure AddRecipient
Lparameters tcRecipientList, tnClass
* tcRecipientpList: comma delimited list of recipients
* tnClass: MAPI_TO, MAPI_CC, MAPI_BCC
Local lcRecipientAddress, lcRecipientList, lcRecipientName, lnClass, lnRecipient, lnRecipients
lnClass = Iif(Type('tnClass') = 'N', m.tnClass, MAPI_TO)
lcRecipientList = Iif(Type('tcRecipientList') = 'C', m.tcRecipientList, '')
lnRecipients = Getwordcount(m.lcRecipientList, [,])
For lnRecipient = 1 To m.lnRecipients
lcRecipientAddress = Getwordnum(m.lcRecipientList, m.lnRecipient, [,])
lcRecipientName = m.lcRecipientAddress
This.rcp.AppendItem(m.lnClass, m.lcRecipientName, m.lcRecipientAddress)
Endfor
Endproc && AddRecipient
Procedure EmailAddAttachment
Lparameters tcAttachment
Return This.att.AppendItem(m.tcAttachment)
Endproc
Procedure EmailClearMessage
This.rcp.ClearItems
This.att.ClearItems
Endproc && EmailClearMessage
*----------------------------------------------------
* Send message
Procedure EmailSend
Local lcMapiMessage, loSubject, loBody, ii, lnResult, lcStoredPath
loSubject = Createobject("PChar", This.cSubject)
loBody = Createobject("PChar", This.cHtmlBody)
lcStoredPath = Sys(5) + Sys(2003)
* assembling MapiMessage structure
lcMapiMessage = num2dword(0) + ;
num2dword(loSubject.getAddr()) + num2dword(loBody.getAddr()) + ;
num2dword(0) + num2dword(0) + num2dword(0) + num2dword(0) + ;
num2dword(This.snd.getAddr()) + ;
num2dword(This.rcp.ItemCount) + num2dword(This.rcp.getAddr()) + ;
num2dword(This.att.ItemCount) + ;
num2dword(Iif(This.att.ItemCount = 0, 0, This.att.getAddr()))
Declare Integer MAPISendMail In mapi32;
INTEGER lhSession, Integer ulUIParam, String @lpMessage, ;
INTEGER flFlags, Integer ulReserved
* Daca nu sunt completate toate informatiile arat emailul utilizatorului
llEmailDisplay = This.lDisplayEmailWithoutInfo And (Empty(This.cTo) Or Empty(This.cSubject) Or (!This.lSendWithoutAttachments And Empty(This.EmailGetAttachmentsNumber())))
llEmailPreview = This.lEmailPreview
Set Step On
&& Daca nu arat fiecare email, il trimit automat
If m.llEmailPreview Or m.llEmailDisplay
lnResult = MAPISendMail(0, 0, @lcMapiMessage, MAPI_DIALOG, 0)
Else
lnResult = MAPISendMail(0, 0, @lcMapiMessage, 0, 0)
Endif
If (m.lnResult <> 0)
This.AddError("ERROR : Message not sent.")
Endif
Set Default To (lcStoredPath)
Return (lnResult = 0) && sendmessage
Endproc
Enddefine && oMapi
*------------------------------------------------------
* oMapi helper classes
Define Class TRecipients As Custom && array of recipients
ItemCount = 0
Dimen arrRecip[1]
RcpsBuffer = .F.
Procedure Destroy
This.UnlockData
This.ClearItems
Procedure getAddr
This.LockData
Return This.RcpsBuffer.getAddr()
Procedure LockData
This.UnlockData
Local lcBuffer, ii
lcBuffer = ""
For ii = 1 To This.ItemCount
lcBuffer = lcBuffer + This.arrRecip[ii].GetValue()
Endfor
This.RcpsBuffer = Createobject("PChar", lcBuffer)
Procedure UnlockData
If Type("THIS.RcpsBuffer") = "O"
This.RcpsBuffer.ReleaseString
This.RcpsBuffer = .F.
Endif
Procedure AppendItem(lnClass, lcName, lcAddress)
This.ItemCount = This.ItemCount + 1
Dimen This.arrRecip[THIS.ItemCount]
This.arrRecip[THIS.ItemCount] = Createobject("TRecipient", lnClass, lcName, lcAddress)
Procedure ClearItems
Local ii
For ii = 1 To This.ItemCount
This.arrRecip[ii].ReleaseRecipient
This.arrRecip[ii] = .F.
Endfor
This.ItemCount = 0
Dimen This.arrRecip[1]
Enddefine && trecipients
Define Class TRecipient As Custom
RcpClass = 0 && 0-sender, 1-primary rec., 2-copy rec., 3-blind copy rec.
RcpName = .F.
RcpAddress = .F.
RcpBuffer = ""
Procedure Init(lnClass, lcName, lcAddress)
This.InitRecipient(lnClass, lcName, lcAddress)
Procedure Destroy
This.ReleaseRecipient
Procedure ReleaseRecipient
If Type("THIS.RcpAddress") = "O"
This.RcpAddress.ReleaseString
This.RcpAddress = .F.
Endif
If Type("THIS.RcpName") = "O"
This.RcpName.ReleaseString
This.RcpName = .F.
Endif
Procedure InitRecipient(lnClass, lcName, lcAddress)
This.ReleaseRecipient
This.RcpName = Createobject("PChar", lcName)
This.RcpAddress = Createobject("PChar", lcAddress)
This.RcpBuffer = num2dword(0) + ;
num2dword(lnClass) + ;
num2dword(This.RcpName.getAddr()) + ;
num2dword(This.RcpAddress.getAddr()) + ;
num2dword(0) + num2dword(0)
Function GetValue
Return This.RcpBuffer
Enddefine && trecipient
Define Class TAttachments As Custom
ItemCount = 0
Dimen arrAttach[1]
AttsBuffer = .F.
Procedure Destroy
This.UnlockData
This.ClearItems
Procedure getAddr
This.LockData
Return This.AttsBuffer.getAddr()
Procedure LockData
This.UnlockData
Local lcBuffer, ii
lcBuffer = ""
For ii = 1 To This.ItemCount
lcBuffer = lcBuffer + This.arrAttach[ii].GetValue()
Endfor
This.AttsBuffer = Createobject("PChar", lcBuffer)
Procedure UnlockData
If Type("THIS.AttsBuffer") = "O"
This.AttsBuffer.ReleaseString
This.AttsBuffer = .F.
Endif
Procedure AppendItem(lcFilename)
If File(lcFilename)
This.ItemCount = This.ItemCount + 1
Dimen This.arrAttach[THIS.ItemCount]
This.arrAttach[THIS.ItemCount] = ;
CREATEOBJECT("TAttachment", lcFilename, This.ItemCount)
Return Type("THIS.arrAttach[THIS.ItemCount]") = "O"
Else
Return .F.
Endif
Procedure ClearItems
Local ii
For ii = 1 To This.ItemCount
This.arrAttach[ii].ReleaseAttachment
This.arrAttach[ii] = .F.
Endfor
This.ItemCount = 0
Dimen This.arrAttach[1]
Enddefine && tattachments
Define Class TAttachment As Custom
AttBuffer = ""
AttFilename = .F.
Procedure Init(lcFilename, nPosition)
This.InitAttachment(m.lcFilename, m.nPosition)
Procedure Destroy
This.ReleaseAttachment
Procedure InitAttachment(lcFilename, nPosition)
*!* typedef struct {
*!* ULONG ulReserved;
*!* ULONG flFlags;
*!* ULONG nPosition;
*!* LPTSTR lpszPathName;
*!* LPTSTR lpszFileName;
*!* LPVOID lpFileType;
*!* } MapiFileDesc, FAR *lpMapiFileDesc;
This.ReleaseAttachment
This.AttFilename = Createobject("PChar", lcFilename)
This.AttBuffer = num2dword(0) + num2dword(0) + ;
num2dword(m.nPosition) + ;
num2dword(This.AttFilename.getAddr()) + ;
num2dword(0) + num2dword(0)
Procedure ReleaseAttachment
If Type("THIS.AttFilename") = "O"
This.AttFilename.ReleaseString
This.AttFilename = .F.
Endif
Function GetValue
Return This.AttBuffer
Enddefine && tattachment
Define Class PChar As Custom
Protected Hmem
Procedure Init(lcString)
This.Hmem = 0
This.setValue(lcString)
Procedure Destroy
This.ReleaseString
Function getAddr && returns a pointer to the string
Return This.Hmem
Function GetValue && returns string value
Local lnSize, lcBuffer
lnSize = This.getAllocSize()
lcBuffer = Space(lnSize)
If This.Hmem <> 0
Declare RtlMoveMemory In kernel32 As MemToStr;
STRING @, Integer, Integer
= MemToStr(@lcBuffer, This.Hmem, lnSize)
Endif
Return lcBuffer
Function getAllocSize && returns allocated memory size (string length)
Declare Integer GlobalSize In kernel32 Integer Hmem
Return Iif(This.Hmem = 0, 0, GlobalSize(This.Hmem))
Procedure setValue(lcString) && assigns new string value
#Define GMEM_FIXED 0
This.ReleaseString
Declare Integer GlobalAlloc In kernel32 Integer, Integer
Declare RtlMoveMemory In kernel32 As StrToMem;
INTEGER, String @, Integer
Local lnSize
lcString = lcString + Chr(0)
lnSize = Len(lcString)
This.Hmem = GlobalAlloc(GMEM_FIXED, lnSize)
If This.Hmem <> 0
= StrToMem(This.Hmem, @lcString, lnSize)
Endif
Procedure ReleaseString && releases allocated memory
If This.Hmem <> 0
Declare Integer GlobalFree In kernel32 Integer
= GlobalFree(This.Hmem)
This.Hmem = 0
Endif
Enddefine && pchar
Function num2dword(lnValue)
#Define m0 256
#Define m1 65536
#Define m2 16777216
Local b0, b1, b2, b3
b3 = Int(lnValue / m2)
b2 = Int((lnValue - b3 * m2) / m1)
b1 = Int((lnValue - b3 * m2 - b2 * m1) / m0)
b0 = Mod(lnValue, m0)
Return Chr(b0) + Chr(b1) + Chr(b2) + Chr(b3)
Endfunc && num2dword