Modificare il file: \iwgallery\ScriptLibrary\incSmartMailer.asp

<SCRIPT LANGUAGE="VBScript" RUNAT="SERVER"> '*** Smart Mailer ---------------------------------------------------- ' Copyright 2003-2005 (c) George Petrov, www.DMXzone.com ' ' Version: 1.0.6 '------------------------------------------------------------------------------ Class SmartMailer ' Define variables Public embedImages Public attFolder Public tmpFolder Public component Public ignore_errors Public contentType Public toRecord Public toRecordName Public toRecordEmail Public progressBar Public useQueue Public ReplyTo Public Priority ' 0 - default, 1 - low, 2 - normal, 3 - high Public pickup Private m_FromName Private m_FromEmail Private m_ToArr Private m_CcArr Private m_BccArr Private m_AttachmentsArr Private m_Subject Private m_HtmlImages Private m_HtmlLinks Private m_Content Private m_fso Private m_Server Private m_ServerPort Private m_ServerUser Private m_ServerPassword Private m_charsetMap Public ContentCharset Public current_mail Public total_mail Private progressFilePath ' Set version Private m_version Private m_debugger ' Init (Use debug if global parameter is set) Private Sub Class_Initialize() m_version = "1.06" m_debugger = DMX_debug Component = "cdo" contentType = "html" embedImages = False ignore_errors = False useQueue = false replyTo = "" current_mail = 0 debug "<br/><font color=""#009900""><b>Smart Mailer version " & m_version & "</b></font><br/><br/>" Set m_ToArr = CreateObject("Scripting.Dictionary") Set m_CcArr = CreateObject("Scripting.Dictionary") Set m_BccArr = CreateObject("Scripting.Dictionary") Set m_AttachmentsArr = CreateObject("Scripting.Dictionary") Set m_HtmlImages = CreateObject("Scripting.Dictionary") Set m_HtmlLinks = CreateObject("Scripting.Dictionary") Set m_fso = CreateObject("Scripting.FileSystemObject") debug "VBScript version = " & ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion & "<br/>" 'check VBscript version if ScriptEngineMajorVersion < 5 then error "vbscript" end if initCharsetMap End Sub Private Sub Class_Terminate() Set m_ToArr = Nothing Set m_CcArr = Nothing Set m_BccArr = Nothing Set m_AttachmentsArr = Nothing Set m_HtmlImages = Nothing Set m_HtmlLinks = Nothing Set m_fso = Nothing End Sub ' Check if version is uptodate Public Sub checkVersion(SM_version) if (SM_version < version) then error("version") end if End Sub ' Set from: Public Sub setFrom(SM_name, SM_email) m_FromName = SM_name m_FromEmail = SM_email End Sub ' Set to Public Sub setTo(SM_name, SM_email) if (SM_email <> "") then m_ToArr.Add SM_email, SM_name debug "Add To: " & SM_name & "(" & SM_email & ")<br/>" end if End Sub ' Set cc Public Sub setCc(SM_name, SM_email) if (SM_email <> "") then m_CcArr.Add SM_email, SM_name end if End Sub ' Set bcc Public Sub setBcc(SM_name, SM_email) if (SM_email <> "") then m_BccArr.Add SM_email, SM_name end if End Sub ' Get subject Public Property Get Subject() Subject = m_Subject End Property ' Set subject Public Property Let Subject(SM_subject) m_Subject = SM_subject End Property ' Set template body Public Sub setBody_Template_html(SM_body) Dim Content, regEx, regExSub, SubMatch, Matches, Match, FullUrl, theFullPath ' Use file as body Content = "" contentType = "html" if InStr(SM_body, "://") = 0 then SM_body = getCurrentPath() & SM_body end if debug "Body = <font color=""#000099""><b>" & SM_body & "</b></font><br/>" Content = getUrl(SM_body) theFullPath = getPath(SM_body) Set regEx = New RegExp ' Create a regular expression. regEx.Pattern = "[=""]\/?([^""\s]*(\.gif|\.jpg|\.jpeg|\.png|\.css|\.js))[""\s]" ' Set pattern. regEx.IgnoreCase = True ' Set case insensitivity. regEx.Global = True ' Set global applicability. Set regExSub = New RegExp ' Create a regular expression. regExSub.Pattern = regEx.Pattern regExSub.IgnoreCase = True ' Set case insensitivity. regExSub.Global = True ' Set global applicability. Set Matches = regEx.Execute(Content) ' Execute search. For Each Match in Matches ' Iterate Matches collection. if InStr(Match, "://") = 0 and InStr(LCase(Match), "mailto:") = 0 and InStr(LCase(Match), "javascript:") = 0 then SubMatch = regExSub.Replace(Match,"$1") ' Execute submatch search. FullUrl = theFullPath & SubMatch addHtmlImage SubMatch, FullUrl end if Next regEx.Pattern = "href\s*=\s*""\/?([^""]*)""" ' Set pattern. regExSub.Pattern = regEx.Pattern Set Matches = regEx.Execute(Content) ' Execute search. For Each Match in Matches ' Iterate Matches collection. if InStr(Match, "://") = 0 and InStr(LCase(Match), "mailto:") = 0 and InStr(LCase(Match), "javascript:") = 0 then SubMatch = regExSub.Replace(Match,"$1") ' Execute submatch search. if SubMatch <> "#" then FullUrl = theFullPath & SubMatch addHtmlLink SubMatch, FullUrl end if end if Next m_Content = Content FixUpHtmlContent End Sub ' Set template body Public Sub setBody_Template_text(SM_body) Dim Content ' Use file as body Content = "" contentType = "text" if InStr(SM_body, "://") = 0 then SM_body = getCurrentPath() & SM_body end if debug "Text Body = <font color=""#000099""><b>" & SM_body & "</b></font><br/>" Content = getUrl(SM_body) m_Content = Content End Sub Public Sub setBody_Static_html(SM_body) Dim Content ' Use file as body Content = Replace(Replace(SM_body,vbCRLF,"<br/>"),chr(13),"<br/>") contentType = "html" debug "Static Html Body = <font color=""#000099"">" & Content & "</font><br/>" if contentCharset <> "" and InStr(LCase(Content),"<head>") = 0 then m_Content = "<html><head>" &_ "<meta http-equiv=""Content-Type"" content=""text/html; charset='" & contentCharset & """>" &_ "</head><body>" & Content & "</body></html>" else m_Content = Content end if End Sub Public Sub setBody_Static_text(SM_body) Dim Content ' Use file as body Content = SM_body contentType = "text" debug "Static Text Body = <font color=""#000099"">" & Content & "</font><br/>" m_Content = Content End Sub ' Setup attachments (Using a recordset) Public Sub setAttRecord(SM_record, SM_field) while NOT SM_record.EOF addAttachment SM_record.Fields.Item(SM_field).Value SM_record.MoveNext() wend End Sub ' Setup attachments (With a list) Public Sub setAttList(SM_files) Dim theAttachments, theFileName theAttachments = split(SM_files,",") For Each theFileName in theAttachments addAttachment theFileName Next End Sub ' Add the attachments to the mail Public Sub setAttFolder(SM_attFolder) Dim SM_fld, SM_files, SM_file, whichFolder if SM_attFolder = "" then whichFolder = "." else whichFolder = SM_attFolder end if Set SM_fld = m_fso.GetFolder(Server.MapPath(whichFolder)) Set SM_files = SM_fld.Files For Each SM_file in SM_files addAttachment SM_file.Name Next End Sub 'Add a single file as attachment Public Sub AddAttachment(SM_fileName) if not m_AttachmentsArr.Exists(SM_fileName) and SM_fileName <> "" then debug "AddAttachment: " & SM_fileName & "<br/>" 'check for existens if InStr(SM_fileName,"://") = 0 then if not m_fso.FileExists(Server.MapPath(SM_fileName)) then Response.Write "Attachment file " & SM_fileName & " can not be found!<br/>Please correct and try again." Response.End end if end if m_AttachmentsArr.Add SM_fileName, SM_fileName end if End Sub ' Setup smtp Public Sub smtpSetup(SM_Server, SM_ServerPort, SM_ServerUser, SM_ServerPassword) m_Server = SM_Server m_ServerPort = SM_ServerPort m_ServerUser = SM_ServerUser m_ServerPassword = SM_ServerPassword End Sub ' The actually sending of the e-mail Public Sub sendMail(SM_multiple) Dim progressFile debug "Sending Mail...<br/>" debug "Component: " & component & "<br/>" if trim(tmpFolder) <> "" then progressFilePath = tmpFolder else progressFilePath = "." end if debug "progressFilePath: " & progressFilePath & "<br/>" if contentCharset = "us-ascii" then contentCharset = "" Select Case LCase(component) Case "cdo" sendMail_CDO() Case "cdonts" sendMail_CDONTS() Case "jmail" sendMail_Jmail() Case "aspemail" sendMail_ASPEmail() Case "aspmail" sendMail_ASPmail() End Select if SM_multiple = "multiple" then current_mail = current_mail + 1 if progressBar <> "" then on error resume next Set progressFile = m_fso.OpenTextFile(Server.MapPath(progressFilePath) & "/" & Session.SessionId, 2, True) if err.number <> 0 then error "progress" end if progressFile.Write "total=" & total_mail & "&current=" & current_mail progressFile.Close on error goto 0 end if end if m_toArr.RemoveAll m_AttachmentsArr.RemoveAll End Sub Private Sub sendMail_CDO() Dim objMail, imageKeys, imageCounter, attachmentKeys, attachmentCounter, theImageFile Dim theSchema, cdoConfig on error resume next set objMail = Server.CreateObject("CDO.Message") if err.number <> 0 then err.clear on error goto 0 sendMail_CDONTS end if on error goto 0 theSchema="http://schemas.microsoft.com/cdo/configuration/" Set cdoConfig=server.CreateObject("CDO.Configuration") if m_Server <> "" then cdoConfig.Fields.Item(theSchema & "sendusing") = 2 cdoConfig.Fields.Item(theSchema & "smtpserver") = m_Server if m_ServerPort <> "" then cdoConfig.Fields.Item(theSchema & "smtpserverport") = m_ServerPort else cdoConfig.Fields.Item(theSchema & "smtpserverport") = 25 end if if m_ServerUser <> "" and m_ServerPassword <> "" then cdoConfig.Fields.Item(theSchema & "smtpauthenticate") = 1 'cdobasic cdoConfig.Fields.Item(theSchema & "sendusername") = m_ServerUser cdoConfig.Fields.Item(theSchema & "sendpassword") = m_ServerPassword end if else cdoConfig.Fields.Item(theSchema & "sendusing") = 1 if pickup <> "" then cdoConfig.Fields.Item(theSchema & "smtpserverpickupdirectory") = pickup end if end if cdoConfig.Fields.Update Set objMail.Configuration = cdoConfig ' Set charset if contentCharset <> "" then objMail.BodyPart.Charset = contentCharset end if if m_FromName <> "" then objMail.From = """" & m_FromName & """ <" & m_FromEmail & ">" else objMail.From = m_FromEmail end if objMail.To = getMultipleAddresses(m_ToArr) if m_CcArr.Count > 0 then objMail.CC = getMultipleAddresses(m_CcArr) end if if m_BccArr.Count > 0 then objMail.BCC = getMultipleAddresses(m_BccArr) end if on error resume next if ContentType = "html" then if m_HtmlImages.Count > 0 and embedImages then ImageKeys = m_HtmlImages.Keys ' Get the keys. For imageCounter = 0 To m_HtmlImages.Count -1 ' Iterate the array. debug "AddRelatedBodyPart: " & m_HtmlImages.Item(ImageKeys(imageCounter)) & " - " & ImageKeys(imageCounter) & "<br/>" contentId = timer & imageCounter objMail.AddRelatedBodyPart m_HtmlImages.Item(ImageKeys(imageCounter)), contentId, 0 if err.number <> 0 and err.number <> -2147220968 and not ignore_errors then Response.Write "AddRelatedBodyPart Error occured! Code " & err.number & " : " & Err.Description & "<br/>" Response.End end if err.clear m_Content = Replace(m_Content,m_HtmlImages.Item(ImageKeys(imageCounter)),"cid:" & contentId) m_Content = Replace(m_Content,ImageKeys(imageCounter),"cid:" & contentId) m_Content = Replace(m_Content,"/cid:" & contentId,"cid:" & contentId) Next end if objMail.HTMLBody = m_Content ' Set charset if contentCharset <> "" then objMail.HTMLBodyPart.Charset = contentCharset end if objMail.MimeFormatted = true else objMail.TextBody = m_Content ' Set charset if contentCharset <> "" then objMail.TextBodyPart.Charset = contentCharset end if end if if m_AttachmentsArr.Count > 0 then attachmentKeys = m_AttachmentsArr.Keys ' Get the keys. For attachmentCounter = 0 To m_AttachmentsArr.Count -1 ' Iterate the array. debug "Attachment: " & m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) & " - " & attachmentKeys(attachmentCounter) & "<br/>" if InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"://") > 0 then objMail.AddAttachment m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) elseif InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"\") > 0 then objMail.AddAttachment m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) else objMail.AddAttachment Server.MapPath(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))) end if if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachFile Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear Next end if if ReplyTo <> "" then objMail.ReplyTo = ReplyTo end if if Priority > 0 then objMail.Fields("urn:schemas:httpmail:importance").Value = Priority - 1 end if objMail.Subject = m_Subject objMail.Send() Set objMail = Nothing if err.number <> 0 and not ignore_errors then Response.Write "SendMail Error: " & Err.description & ", code = " & err.number Response.End end if on error goto 0 End Sub Private Sub sendMail_CDONTS() Dim objMail, imageKeys, imageCounter, attachmentKeys, attachmentCounter, theImageFile on error resume next Set objMail = Server.CreateObject("CDONTS.NewMail") if err.number <> 0 then error "cdo" end if on error goto 0 ' Set charset on error resume next objMail.SetLocaleIDs getCodepage() on error goto 0 if m_FromName <> "" then objMail.From = """" & m_FromName & """ <" & m_FromEmail & ">" else objMail.From = m_FromEmail end if objMail.To = getMultipleAddresses(m_ToArr) if m_CcArr.Count > 0 then objMail.CC = getMultipleAddresses(m_CcArr) end if if m_BccArr.Count > 0 then objMail.BCC = getMultipleAddresses(m_BccArr) end if on error resume next if ContentType = "html" then objMail.MailFormat = 0 ' HTML Mail if m_HtmlImages.Count > 0 and embedImages then ImageKeys = m_HtmlImages.Keys ' Get the keys. For imageCounter = 0 To m_HtmlImages.Count -1 ' Iterate the array. debug "AttachURL: " & m_HtmlImages.Item(ImageKeys(imageCounter)) & " - " & ImageKeys(imageCounter) & "<br/>" objMail.AttachURL getBinaryUrl(m_HtmlImages.Item(ImageKeys(imageCounter))), ImageKeys(imageCounter) if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachURL Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear Next end if end if if ContentType = "html" or m_AttachmentsArr.Count > 0 then objMail.BodyFormat = 0 ' MIME Mail if m_AttachmentsArr.Count > 0 then attachmentKeys = m_AttachmentsArr.Keys ' Get the keys. For attachmentCounter = 0 To m_AttachmentsArr.Count -1 ' Iterate the array. debug "Attachment: " & m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) & " - " & attachmentKeys(attachmentCounter) & "<br/>" if InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"://") > 0 then objMail.AttachFile getBinaryUrl(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))), attachmentKeys(attachmentCounter) elseif InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"\") > 0 then objMail.AttachFile m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)), attachmentKeys(attachmentCounter) else objMail.AttachFile Server.MapPath(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))), attachmentKeys(attachmentCounter) end if if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachFile Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear Next end if end if if ReplyTo <> "" then objMail.Value("Reply-To") = ReplyTo end if if Priority > 0 then objMail.Importance = Priority - 1 end if objMail.Subject = m_Subject objMail.Body = m_Content objMail.Send() Set objMail = Nothing if err.number <> 0 and not ignore_errors then Response.Write "SendMail Error: " & Err.description & ", code = " & err.number Response.End end if on error goto 0 End Sub Private Sub sendMail_JMail() Dim objMail, imageKeys, imageCounter, attachmentKeys, attachmentCounter, theImageFile Dim emailKeys, emailCounter, JMailVersion Application.Lock JMailVersion = Application("JMailVersion") Application.Unlock if JMailVersion = "" then on error resume next err.clear Set objMail = Server.CreateObject("JMail.Message") if err.number = 0 then JMailVersion = "4" else Set objMail = Server.CreateObject("JMail.SMTPMail") if err.number = 0 then JMailVersion = "3" else error "jmail" end if end if on error goto 0 Application.Lock Application("JMailVersion") = JMailVersion Application.Unlock else if JMailVersion = "3" then Set objMail = Server.CreateObject("JMail.SMTPMail") else Set objMail = Server.CreateObject("JMail.Message") end if end if debug "JMailVersion: " & JMailVersion & "<br/>" if JMailVersion = "3" then objMail.ServerAddress = m_Server objMail.Sender = m_FromEmail if m_FromName <> "" then objMail.SenderName = m_FromName end if else objMail.From = m_FromEmail if m_FromName <> "" then objMail.FromName = m_FromName end if end if if m_ToArr.Count > 0 then EmailKeys = m_ToArr.Keys ' Get the keys. For emailCounter = 0 To m_ToArr.Count -1 ' Iterate the array. if JMailVersion = "3" then if m_ToArr.Item(EmailKeys(emailCounter)) <> "" then objMail.AddRecipientEx EmailKeys(emailCounter), m_ToArr.Item(EmailKeys(emailCounter)) else objMail.AddRecipient EmailKeys(emailCounter) end if else if m_ToArr.Item(EmailKeys(emailCounter)) <> "" then objMail.AddRecipient EmailKeys(emailCounter), m_ToArr.Item(EmailKeys(emailCounter)) else objMail.AddRecipient EmailKeys(emailCounter) end if end if Next end if if m_CcArr.Count > 0 then EmailKeys = m_CcArr.Keys ' Get the keys. For emailCounter = 0 To m_CcArr.Count -1 ' Iterate the array. if JMailVersion = "3" then objMail.AddRecipientCC EmailKeys(emailCounter) else if m_CcArr.Item(EmailKeys(emailCounter)) <> "" then objMail.AddRecipientCC EmailKeys(emailCounter), m_CcArr.Item(EmailKeys(emailCounter)) else objMail.AddRecipientCC EmailKeys(emailCounter) end if end if Next end if if m_BccArr.Count > 0 then EmailKeys = m_BccArr.Keys ' Get the keys. For emailCounter = 0 To m_BccArr.Count -1 ' Iterate the array. objMail.AddRecipientBCC EmailKeys(emailCounter) Next end if on error resume next if ContentType = "html" then objMail.ContentType = "text/html" ' HTML Mail if m_HtmlImages.Count > 0 and embedImages and JMailVersion = "4" then ImageKeys = m_HtmlImages.Keys ' Get the keys. For imageCounter = 0 To m_HtmlImages.Count -1 ' Iterate the array. debug "AttachURL: " & m_HtmlImages.Item(ImageKeys(imageCounter)) & " - " & ImageKeys(imageCounter) & "<br/>" contentId = objMail.AddAttachment(getBinaryUrl(m_HtmlImages.Item(ImageKeys(imageCounter))), true) if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachURL Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear m_Content = Replace(m_Content,m_HtmlImages.Item(ImageKeys(imageCounter)),"cid:" & contentId) m_Content = Replace(m_Content,ImageKeys(imageCounter),"cid:" & contentId) m_Content = Replace(m_Content,"/cid:" & contentId,"cid:" & contentId) Next end if end if if m_AttachmentsArr.Count > 0 then attachmentKeys = m_AttachmentsArr.Keys ' Get the keys. For attachmentCounter = 0 To m_AttachmentsArr.Count -1 ' Iterate the array. debug "Attachment: " & m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) & " - " & attachmentKeys(attachmentCounter) & "<br/>" if InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"://") > 0 then objMail.AddAttachment(getBinaryUrl(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)))) elseif InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"\") > 0 then objMail.AddAttachment(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))) else objMail.AddAttachment(Server.MapPath(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)))) end if if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachFile Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear Next end if 'set charset if contentCharset <> "" then objMail.Charset = contentCharset end if if ReplyTo <> "" then objMail.ReplyTo = ReplyTo end if if Priority > 0 then select case Priority case 1 ' low objMail.Priority = 5 case 2 ' normal objMail.Priority = 3 case 3 ' high objMail.Priority = 1 end select end if objMail.Subject = m_Subject objMail.Body = m_Content if JMailVersion = "4" and ContentType = "html" then objMail.HTMLBody = m_Content end if if JMailVersion = "3" then objMail.Execute() else if useQueue then if pickup <> "" then objMail.MSPickupDirectory = pickup end if objMail.nq else if (m_ServerUser <> "" and m_ServerPassword <> "") then objMail.Send(m_ServerUser & ":" & m_ServerPassword & "@" & m_Server & ":" & m_ServerPort) else objMail.Send(m_Server & ":" & m_ServerPort) end if end if end if objMail.Close() Set objMail = Nothing if err.number <> 0 and not ignore_errors then Response.Write "SendMail Error: " & Err.description & ", code = " & err.number Response.End end if on error goto 0 End Sub Private Sub sendMail_ASPEmail() Dim objMail, imageKeys, imageCounter, attachmentKeys, attachmentCounter, theImageFile Dim emailKeys, emailCounter, useVer45 useVer45 = false on error resume next Set objMail = Server.CreateObject("Persits.MailSender") if err.number <> 0 then error "aspemail" end if on error goto 0 if m_Server <> "" then objMail.Host = m_Server end if if m_ServerPort <> "" then objMail.Port = m_ServerPort end if if m_ServerUser <> "" then objMail.Username = m_ServerUser end if if m_ServerPassword <> "" then objMail.Password = m_ServerPassword end if objMail.From = m_FromEmail 'set charset if contentCharset <> "" then objMail.CharSet = contentCharset objMail.ContentTransferEncoding = "Quoted-Printable" on error resume next objMail.FromName = objMail.EncodeHeader(m_FromName,contentCharset) if err.number <> 0 then 'Old version of ASPemail - don't support second parameter err.clear on error goto 0 useVer45 = true if Trim(m_FromName) <> "" then objMail.FromName = objMail.EncodeHeader(m_FromName) end if objMail.Subject = objMail.EncodeHeader(m_Subject) if m_ToArr.Count > 0 then EmailKeys = m_ToArr.Keys ' Get the keys. For emailCounter = 0 To m_ToArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddAddress EmailKeys(emailCounter), objMail.EncodeHeader(m_ToArr.Item(EmailKeys(emailCounter))) else objMail.AddAddress EmailKeys(emailCounter) end if Next end if if m_CcArr.Count > 0 then EmailKeys = m_CcArr.Keys ' Get the keys. For emailCounter = 0 To m_CcArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddCC EmailKeys(emailCounter), objMail.EncodeHeader(m_CcArr.Item(EmailKeys(emailCounter))) else objMail.AddCC EmailKeys(emailCounter) end if Next end if if m_BccArr.Count > 0 then EmailKeys = m_BccArr.Keys ' Get the keys. For emailCounter = 0 To m_BccArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddBcc EmailKeys(emailCounter), objMail.EncodeHeader(m_BccArr.Item(EmailKeys(emailCounter))) else objMail.AddBcc EmailKeys(emailCounter) end if Next end if else 'use ver 5 parameters on error goto 0 objMail.Subject = objMail.EncodeHeader(m_Subject,contentCharset) if m_ToArr.Count > 0 then EmailKeys = m_ToArr.Keys ' Get the keys. For emailCounter = 0 To m_ToArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddAddress EmailKeys(emailCounter), objMail.EncodeHeader(m_ToArr.Item(EmailKeys(emailCounter)),contentCharset) else objMail.AddAddress EmailKeys(emailCounter) end if Next end if if m_CcArr.Count > 0 then EmailKeys = m_CcArr.Keys ' Get the keys. For emailCounter = 0 To m_CcArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddCC EmailKeys(emailCounter), objMail.EncodeHeader(m_CcArr.Item(EmailKeys(emailCounter)),contentCharset) else objMail.AddCC EmailKeys(emailCounter) end if Next end if if m_BccArr.Count > 0 then EmailKeys = m_BccArr.Keys ' Get the keys. For emailCounter = 0 To m_BccArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddBcc EmailKeys(emailCounter), objMail.EncodeHeader(m_BccArr.Item(EmailKeys(emailCounter)),contentCharset) else objMail.AddBcc EmailKeys(emailCounter) end if Next end if end if else 'default encoding objMail.FromName = m_FromName objMail.Subject = m_Subject if m_ToArr.Count > 0 then EmailKeys = m_ToArr.Keys ' Get the keys. For emailCounter = 0 To m_ToArr.Count -1 ' Iterate the array. objMail.AddAddress EmailKeys(emailCounter), m_ToArr.Item(EmailKeys(emailCounter)) Next end if if m_CcArr.Count > 0 then EmailKeys = m_CcArr.Keys ' Get the keys. For emailCounter = 0 To m_CcArr.Count -1 ' Iterate the array. objMail.AddCC EmailKeys(emailCounter), m_CcArr.Item(EmailKeys(emailCounter)) Next end if if m_BccArr.Count > 0 then EmailKeys = m_BccArr.Keys ' Get the keys. For emailCounter = 0 To m_BccArr.Count -1 ' Iterate the array. objMail.AddBcc EmailKeys(emailCounter), m_BccArr.Item(EmailKeys(emailCounter)) Next end if end if 'charset on error resume next if ContentType = "html" then objMail.IsHTML = True ' HTML Mail if m_HtmlImages.Count > 0 and embedImages then ImageKeys = m_HtmlImages.Keys ' Get the keys. For imageCounter = 0 To m_HtmlImages.Count -1 ' Iterate the array. debug "AttachURL: " & m_HtmlImages.Item(ImageKeys(imageCounter)) & " - " & ImageKeys(imageCounter) & "<br/>" if InStr(ImageKeys(imageCounter),"://") = 0 then if m_fso.FileExists(Server.MapPath(ImageKeys(imageCounter))) then objMail.AddEmbeddedImage Server.MapPath(ImageKeys(imageCounter)), ImageKeys(imageCounter) end if else objMail.AddEmbeddedImageMem ImageKeys(imageCounter), ImageKeys(imageCounter), getBinaryUrl(m_HtmlImages.Item(ImageKeys(imageCounter))) end if if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachURL Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear m_Content = Replace(m_Content,m_HtmlImages.Item(ImageKeys(imageCounter)),"cid:" & contentId) m_Content = Replace(m_Content,ImageKeys(imageCounter),"cid:" & ImageKeys(imageCounter)) m_Content = Replace(m_Content,"/cid:" & contentId,"cid:" & contentId) Next end if end if if ContentType = "html" or m_AttachmentsArr.Count > 0 then if m_AttachmentsArr.Count > 0 then attachmentKeys = m_AttachmentsArr.Keys ' Get the keys. For attachmentCounter = 0 To m_AttachmentsArr.Count -1 ' Iterate the array. debug "Attachment: " & m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) & " - " & attachmentKeys(attachmentCounter) & "<br/>" if InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"://") > 0 then objMail.AddAttachmentMem attachmentKeys(attachmentCounter), getBinaryUrl(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))) elseif InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"\") > 0 then objMail.AddAttachment m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) else objMail.AddAttachment Server.MapPath(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))) end if if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachFile Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear Next end if end if if ReplyTo <> "" then objMail.AddReplyTo ReplyTo end if if Priority > 0 then select case Priority case 1 ' low objMail.Priority = 5 case 2 ' normal objMail.Priority = 3 case 3 ' high objMail.Priority = 1 end select end if objMail.Body = m_Content if useQueue then objMail.Queue = True end if objMail.Send() Set objMail = Nothing if err.number <> 0 and not ignore_errors then Response.Write "SendMail Error: " & Err.description & ", code = " & err.number Response.End end if on error goto 0 End Sub Private Sub sendMail_ASPmail() Dim objMail, imageKeys, imageCounter, attachmentKeys, attachmentCounter, theImageFile Dim emailKeys, emailCounter on error resume next Set objMail = Server.CreateObject("SMTPsvg.Mailer") if err.number <> 0 then error "aspmail" end if on error goto 0 objMail.RemoteHost = m_Server if contentCharset <> "" then objMail.CustomCharSet = contentCharset if Trim(m_FromName) <> "" then objMail.FromName = objMail.EncodeHeader(m_FromName) end if objMail.FromAddress = m_FromEmail objMail.Subject = objMail.EncodeHeader(m_Subject) if m_ToArr.Count > 0 then EmailKeys = m_ToArr.Keys ' Get the keys. For emailCounter = 0 To m_ToArr.Count -1 ' Iterate the array. if Trim(m_ToArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddRecipient objMail.EncodeHeader(m_ToArr.Item(EmailKeys(emailCounter))), EmailKeys(emailCounter) else objMail.AddRecipient EmailKeys(emailCounter), EmailKeys(emailCounter) end if Next end if if m_CcArr.Count > 0 then EmailKeys = m_CcArr.Keys ' Get the keys. For emailCounter = 0 To m_CcArr.Count -1 ' Iterate the array. if Trim(m_CcArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddCC objMail.EncodeHeader(m_CcArr.Item(EmailKeys(emailCounter))), EmailKeys(emailCounter) else objMail.AddCC EmailKeys(emailCounter), EmailKeys(emailCounter) end if Next end if if m_BccArr.Count > 0 then EmailKeys = m_BccArr.Keys ' Get the keys. For emailCounter = 0 To m_BccArr.Count -1 ' Iterate the array. if Trim(m_BccArr.Item(EmailKeys(emailCounter))) <> "" then objMail.AddBCC objMail.EncodeHeader(m_BccArr.Item(EmailKeys(emailCounter))), EmailKeys(emailCounter) else objMail.AddBCC EmailKeys(emailCounter), EmailKeys(emailCounter) end if Next end if else objMail.FromName = m_FromName objMail.FromAddress = m_FromEmail objMail.Subject = m_Subject if m_ToArr.Count > 0 then EmailKeys = m_ToArr.Keys ' Get the keys. For emailCounter = 0 To m_ToArr.Count -1 ' Iterate the array. objMail.AddRecipient m_ToArr.Item(EmailKeys(emailCounter)), EmailKeys(emailCounter) Next end if if m_CcArr.Count > 0 then EmailKeys = m_CcArr.Keys ' Get the keys. For emailCounter = 0 To m_CcArr.Count -1 ' Iterate the array. objMail.AddCC m_CcArr.Item(EmailKeys(emailCounter)), EmailKeys(emailCounter) Next end if if m_BccArr.Count > 0 then EmailKeys = m_BccArr.Keys ' Get the keys. For emailCounter = 0 To m_BccArr.Count -1 ' Iterate the array. objMail.AddBCC m_BccArr.Item(EmailKeys(emailCounter)), EmailKeys(emailCounter) Next end if end if on error resume next if ContentType = "html" then objMail.ContentType = "text/html" ' HTML Mail end if if m_AttachmentsArr.Count > 0 then attachmentKeys = m_AttachmentsArr.Keys ' Get the keys. For attachmentCounter = 0 To m_AttachmentsArr.Count -1 ' Iterate the array. debug "Attachment: " & m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) & " - " & attachmentKeys(attachmentCounter) & "<br/>" if InStr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"://") > 0 then objMail.AddAttachment getBinaryUrl(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))) elseif Instr(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)),"\") > 0 then objMail.AddAttachment m_AttachmentsArr.Item(attachmentKeys(attachmentCounter)) else objMail.AddAttachment Server.MapPath(m_AttachmentsArr.Item(attachmentKeys(attachmentCounter))) end if if err.number <> 0 and err.number <> 424 and not ignore_errors then response.Write "AttachFile Error occured! Code " & err.number & " : " & Err.Description Response.End end if err.clear Next end if if ReplyTo <> "" then objMail.ReplyTo = ReplyTo end if if Priority > 0 then select case Priority case 1 ' low objMail.Priority = 5 case 2 ' normal objMail.Priority = 3 case 3 ' high objMail.Priority = 1 end select end if objMail.BodyText = m_Content if not objMail.SendMail() and not ignore_errors then Response.Write "SendMail Error: " & objMail.Response Set objMail = Nothing Response.End end if Set objMail = Nothing on error goto 0 End Sub Private Function getMultipleAddresses(theArr) Dim Emails,EmailCounter,fullAddress fullAddress = "" Emails = theArr.Keys ' Get the keys. For linksCounter = 0 To theArr.Count -1 ' Iterate the array. if theArr.Item(Emails(linksCounter)) <> "" then fullAddress = """" & theArr.Item(Emails(linksCounter)) & """ <" & Emails(linksCounter) & ">;" else fullAddress = Emails(linksCounter) & ";" end if Next debug "getMultipleAddresses: " & fullAddress & "<br/>" getMultipleAddresses = fullAddress End Function ' Done Public Sub done() debug "Done...<br/>" if progressBar <> "" then if m_fso.FileExists(Server.MapPath(progressFilePath) & "/" & Session.SessionId) then m_fso.DeleteFile(Server.MapPath(progressFilePath) & "/" & Session.SessionId) end if end if End Sub Private Sub FixUpHtmlContent() Dim linkNames, linksCounter, imageNames, imagesCounter 'Fix up or include html images if embedImages then else imageNames = m_HtmlImages.Keys ' Get the keys. For imagesCounter = 0 To m_HtmlImages.Count -1 ' Iterate the array. debug "Images: " & imageNames(imagesCounter) & " -> " & m_HtmlImages.Item(imageNames(imagesCounter)) & "<BR/>" m_Content = Replace(m_Content, """" & imageNames(imagesCounter) & """", """" & m_HtmlImages.Item(imageNames(imagesCounter)) & """") m_Content = Replace(m_Content, "/""" & m_HtmlImages.Item(imageNames(imagesCounter)) & """", """" & m_HtmlImages.Item(imageNames(imagesCounter)) & """") Next end if 'Fix up all links LinkNames = m_HtmlLinks.Keys ' Get the keys. For linksCounter = 0 To m_HtmlLinks.Count -1 ' Iterate the array. debug "Links: " & linkNames(linksCounter) & " -> " & m_HtmlLinks.Item(linkNames(linksCounter)) & "<BR/>" m_Content = Replace(m_Content, """" & linkNames(linksCounter) & """", """" & m_HtmlLinks.Item(linkNames(linksCounter)) & """") m_Content = Replace(m_Content, "/""" & m_HtmlLinks.Item(linkNames(linksCounter)) & """", """" & m_HtmlLinks.Item(linkNames(linksCounter)) & """") Next End Sub ' Debugger Private Sub debug(SM_info) if m_debugger then Response.Write "<font face=""verdana"" size=""2"">" & SM_info & "</font>" end if End Sub ' Display error Private Sub error(SM_error) Response.Write "<b>Error sending e-mail</b><br/><br/>" Select Case SM_error ' Not correct version Case "open" Response.Write "<br>Could not open the URL to the template<br/>" ' Not correct version case "version" Response.Write "Please upload the latest version of incSmartImage.php<br/>" ' Error sending e-mail thru smtp case "smtp" 'todo ' Error sending email thru sendmail case "sendmail" Response.Write "An error occured when trying to send the e-mail<br/>" case "progress" Response.Write "Could not write progress file information.<br/>Please make sure you have a write access to the folder that is specified as temp Folder<br/>" case "vbscript" Response.Write "You are using an old VBScript version!<br/>You are now using version " &_ ScriptEngineMajorVersion & "." & ScriptEngineMinorVersion &_ " and you must use at least version 5.0<br/>" &_ "Please go to <a href=""http://msdn.microsoft.com/scripting"" target=""_blank"">http://msdn.microsoft.com/scripting</a> and install the latest Scripting Engine<br/>" case "cdo" Response.Write "Could not find the CDO Mail component!<br/>Please make sure it is installed.<br/>" case "jmail" Response.Write "Could not find the JMail component!<br/>Please make sure it is installed.<br/>" case "aspemail" Response.Write "Could not find the ASPEmail component!<br/>Please make sure it is installed.<br/>" case "aspmail" Response.Write "Could not find the ASPmail component!<br/>Please make sure it is installed.<br/>" End Select ' Allow to go back and stop the script Response.Write "Please correct and <a href=""javascript:history.back(1)"">try again</a>" Response.End End Sub ' Add Html Image Private Sub AddHtmlImage(SM_imageUrl, SM_fullUrl) if not m_HtmlImages.Exists(SM_imageUrl) then debug "AddHtmlImage: " & SM_imageUrl & " -> " & SM_fullUrl & "<br/>" m_HtmlImages.Add SM_imageUrl, SM_fullUrl if embedImages then 'todo: get the binary image end if end if End Sub ' Add Html Link Private Sub AddHtmlLink(SM_LinkUrl, SM_fullUrl) if not m_HtmlLinks.Exists(SM_LinkUrl) then debug "AddHtmlLink: " & SM_LinkUrl & " -> " & SM_fullUrl & "<br/>" m_HtmlLinks.Add SM_LinkUrl, SM_fullUrl end if End Sub ' Get current path Private Function getCurrentPath() Dim CurrentPath CurrentPath = "http://" & Request.ServerVariables("SERVER_NAME") & Request.ServerVariables("SCRIPT_NAME") CurrentPath = Mid(CurrentPath,1,InStrRev(CurrentPath,"/")) getCurrentPath = CurrentPath End Function ' Get path Private Function getPath(SM_Url) Dim thePath, StartPathPos, EndPathPos thePath = SM_Url StartPathPos = InStr(thePath,"://") EndPathPos = InStrRev(thePath,"/") if StartPathPos > 0 then if EndPathPos > StartPathPos + 3 then thePath = Mid(thePath,1,EndPathPos) end if else thePath = Mid(thePath,1,InStrRev(thePath,"/")) end if if right(thePath,1) <> "/" then thePath = thePath & "/" getPath = thePath End Function ' Get a specific URL via HTTP Private Function GetUrl(SM_Url) Dim objHttp, objText, HttpComponent HttpComponent = GetHttpComponent() on error resume next set objHttp = Server.CreateObject(HttpComponent) if err.number <> 0 then Response.Write "ERROR: Can not get Template URL!<br>" & err.description & "<br/>" Response.End end if on error goto 0 objHttp.open "GET", SM_Url, false objHttp.setRequestHeader "User-Agent", Request.ServerVariables("HTTP_USER_AGENT") objHttp.Send "" objText = objHttp.responseText ' Check notification validation if (objHttp.status <> 200 ) then ' HTTP error handling Response.Write "HTTP ERROR: " & objHttp.status & "<br/>" Response.Write "Returned:<br/>" & objHttp.responseText Response.End end if GetUrl = objText End Function ' Get a specific URL via HTTP Private Function GetBinaryUrl(SM_Url) Dim objHttp, objText, HttpComponent HttpComponent = GetHttpComponent() on error resume next set objHttp = Server.CreateObject(HttpComponent) if err.number <> 0 then Response.Write "ERROR: Can not get Binary URL!<br/>" & err.description & "<br/>" Response.End end if on error goto 0 objHttp.open "GET", SM_Url, false objHttp.setRequestHeader "User-Agent", Request.ServerVariables("HTTP_USER_AGENT") objHttp.Send "" ' Check notification validation if (objHttp.status <> 200 and objHttp.status <> 404) then ' HTTP error handling Response.Write "HTTP ERROR: " & objHttp.status & "<br>" Response.Write "Returned:<br>" & objHttp.responseText Response.End end if if objHttp.status <> 404 then Set GetBinaryUrl = objHttp.ResponseStream else Set GetBinaryUrl = Null end if End Function Private Function GetHttpComponent() Dim HttpComponent Application.Lock HttpComponent = Application("HttpComponent") Application.Unlock if HttpComponent = "" then 'Check for Http Components if CheckHttpComponent("Msxml2.ServerXMLHTTP.3.0") = true then HttpComponent = "Msxml2.ServerXMLHTTP.3.0" else if CheckHttpComponent("Msxml2.ServerXMLHTTP") = true then HttpComponent = "Msxml2.ServerXMLHTTP" else if CheckHttpComponent("Microsoft.XMLHTTP") = true then HttpComponent = "Microsoft.XMLHTTP" else end if end if end if Application.Lock Application("HttpComponent") = HttpComponent Application.Unlock end if debug "Found Http Component: " & HttpComponent & "<br/>" GetHttpComponent = HttpComponent end function Private Function CheckHttpComponent(HttpObj) dim objHttp, Detection Detection = false on error resume next err.clear debug "Checking " & HttpObj & "<br>" Set objHttp = Server.CreateObject(HttpObj) if err.number = 0 then Detection = True Set objHttp = nothing End if on error goto 0 debug "Detection is " & Detection & "<br>" CheckHttpComponent = Detection end function Public Function getTotalRecords(SM_Recordset) Dim theTotalRecords theTotalRecords = SM_Recordset.RecordCount If (theTotalRecords = -1) Then ' count the total records by iterating through the recordset theTotalRecords = 0 While (Not SM_Recordset.EOF) theTotalRecords = theTotalRecords + 1 SM_Recordset.MoveNext Wend ' reset the cursor to the beginning If (SM_Recordset.CursorType > 0) Then SM_Recordset.MoveFirst Else SM_Recordset.Requery End If End If getTotalRecords = theTotalRecords End Function Public function getCodepage() Dim cm_index, theCodepage theCodepage = 20127 'default us-ascii if contentCharset <> "" then for cm_index = 0 to UBOUND(m_charsetMap)-1 step 3 if LCase(m_charsetMap(cm_index+1)) = LCase(contentCharset) then theCodepage = CLng(m_charsetMap(cm_index+2)) exit for end if next end if getCodepage = theCodepage end function Private sub initCharsetMap() m_charsetMap = Array("Arabic (ASMO 708)","ASMO-708","708", _ "Arabic (ISO)","iso-8859-6","28596", _ "Arabic (Windows)","windows-1256","1256", _ "Baltic (ISO)","iso-8859-4","28594", _ "Baltic (Windows)","windows-1257","1257", _ "Central European (DOS)","ibm852","852", _ "Central European (ISO)","iso-8859-2","28592", _ "Central European (Windows)","windows-1250","1250", _ "Chinese Simplified (EUC)","EUC-CN","51936", _ "Chinese Simplified (GB2312)","gb2312","936", _ "Chinese Simplified (HZ)","hz-gb-2312","52936", _ "Chinese Traditional (Big5)","big5","950", _ "Cyrillic (DOS)","cp866","866", _ "Cyrillic (ISO)","iso-8859-5","28595", _ "Cyrillic (KOI8-R)","koi8-r","20866", _ "Cyrillic (KOI8-U)","koi8-u","21866", _ "Cyrillic (Windows)","windows-1251","1251", _ "Greek (ISO)","iso-8859-7","28597", _ "Greek (Windows)","windows-1253","1253", _ "Hebrew (DOS)","DOS-862","862", _ "Hebrew (ISO-Logical)","iso-8859-8-i","38598", _ "Hebrew (ISO-Visual)","iso-8859-8","28598", _ "Hebrew (Windows)","windows-1255","1255", _ "Japanese (EUC)","euc-jp","51932", _ "Japanese (JIS)","iso-2022-jp","50220", _ "Japanese (Shift-JIS)","shift_jis","932", _ "Korean (EUC)","euc-kr","51949", _ "Korean (ISO)","iso-2022-kr","50225", _ "Korean (Johab)","Johab","1361", _ "Latin 3 (ISO)","iso-8859-3","28593", _ "Latin 9 (ISO)","iso-8859-15","28605", _ "Norwegian (IA5)","x-IA5-Norwegian","20108", _ "Swedish (IA5)","x-IA5-Swedish","20107", _ "Thai (Windows)","windows-874","874", _ "Turkish (ISO)","iso-8859-9","28599", _ "Turkish (Windows)","windows-1254","1254", _ "Unicode (UTF-8)","utf-8","65001", _ "US-ASCII","us-ascii","20127", _ "Vietnamese (Windows)","windows-1258","1258", _ "Western European (ISO)","iso-8859-1","28591", _ "Western European (Windows)","Windows-1252","1252" ) End sub End Class function getMailAction() Dim MailAction, theQueryString theQueryString = Request.QueryString if theQueryString <> "" then MailAction = CStr(Request.ServerVariables("URL")) & "?" & UploadQueryString else MailAction = CStr(Request.ServerVariables("URL")) end if getMailAction = MailAction end function Function createSmartMailer Set createSmartMailer = New SmartMailer End Function </SCRIPT>

[Íàçàä]