<!--METADATA TYPE="typelib" UUID="CD000000-8B95-11D1-82DB-00C04FB1625D" NAME="CDO for Windows 2000 Type Library" -->
<%
' CxMail: Copyright (C) 2008 Walter Bislin
' http://walter.bislins.ch/projekte/asp/xmail/
'
' currently supported Mail-Components: "CDOSYS", "Persits"
'
' CDOSYS: http://www.w3schools.com/asp/asp_send_email.asp
' Persits: http://www.aspemail.com/index.html
'
' dependecies:
' - xmailutil.inc
class CCdosysMail
public MailHost ' like "mail.mydomain.com"
public Port
public PickupFolder ' Default is c:\Inetpub\mailroot\Pickup
public Queue ' default is true
public UserName
public Password
public FromAddr
public FromName
public Subject
public Body
public AltBody
public IsHtml
public CharSet
private mToList ' CDynArray
private mCcList ' CDynArray
private mBccList ' CDynArray
private sub Class_Initialize()
MailHost = ""
Port = 25
PickupFolder = "c:\Inetpub\mailroot\Pickup"
Queue = true
UserName = ""
Password = ""
FromAddr = ""
FromName = ""
Subject = ""
Body = ""
AltBody = ""
IsHtml = false
CharSet = CdoUTF_8 ' CdoUTF_8 = "utf-8", CdoISO_8859_1 = "iso-8859-1"
set mToList = NewDynArray(0)
set mCcList = NewDynArray(0)
set mBccList = NewDynArray(0)
end sub
sub ClearRecipients()
mToList.Clear
mCcList.Clear
mBccList.Clear
end sub
sub ClearAll()
ClearRecipients
FromAddr = ""
FromName = ""
Subject = ""
Body = ""
IsHtml = fase
end sub
sub AddTo( aToAddr, aToName )
mToList.AddItem ComposeRecipient(aToAddr,aToName)
end sub
sub AddCc( aToAddr, aToName )
mCcList.AddItem ComposeRecipient(aToAddr,aToName)
end sub
sub AddBcc( aToAddr, aToName )
mBccList.AddItem ComposeRecipient(aToAddr,aToName)
end sub
private function ComposeRecipient( aToAddr, aToName )
dim s
s = "<" & aToAddr & ">"
if Len(aToName) > 0 then
s = """" & Replace(aToName,"""","''") & """ " & s
end if
ComposeRecipient = s
end function
sub Send()
dim cdoMessage, cdoConfig
set cdoConfig = CreateObject("CDO.Configuration")
if Queue then
With cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPickup
.Item(cdoSMTPServerPickupDirectory) = PickupFolder
.Update
End With
else
With cdoConfig.Fields
.Item(cdoSendUsingMethod) = cdoSendUsingPort
.Item(cdoSMTPServer) = MailHost
.Item(cdoSMTPServerPort) = Port
if Len(UserName) > 0 then
.Item(cdoSMTPAuthenticate) = cdoBasic
.Item(cdoSendUserName) = UserName
.Item(cdoSendPassword) = Password
end if
.Update
End With
end if
set cdoMessage = Server.CreateObject("CDO.Message")
With cdoMessage
set .Configuration = cdoConfig
.BodyPart.Charset = CharSet
.MimeFormatted = true
.From = ComposeRecipient( FromAddr, FromName )
.To = mToList.JoinItems(", ", false)
.Cc = mCcList.JoinItems(", ", false)
.Bcc = mBccList.JoinItems(", ", false)
.Subject = Subject
if IsHtml then
if Len(AltBody) = 0 then
.AutoGenerateTextBody = true
else
.AutoGenerateTextBody = false
.TextBody = AltBody
end if
.HtmlBody = Body
.HtmlBodyPart.Charset = CharSet
.HtmlBodyPart.ContentTransferEncoding = cdoQuotedPrintable
else
.AutoGenerateTextBody = false
.TextBody = Body
end if
.TextBodyPart.Charset = CharSet
.TextBodyPart.ContentTransferEncoding = cdoQuotedPrintable
.Send
End With
set cdoMessage = Nothing
set cdoConfig = Nothing
end sub
end class
'---------------------
class CxMailComponent
public Name
public ClassName
public IsAvailable
public DocUrl
end class
const CxMailerNoneId = -1
const CxMailerCdosysId = 0
const CxMailerPersitsId = 1
class CxMail
public MailHost ' like "mail.mydomain.com"
public Port
public PickupFolder ' Default is c:\Inetpub\mailroot\Pickup
public Queue
public UserName
public Password
public FromAddr
public FromName
public Subject
public Body
public AltBody ' if not specified when IsHtml is true, then it is generated from Body
public IsHtml ' if true, allway multipart is sent (autogen of AltBody if not defined)
public CharSet ' "utf-8" (Default), "iso-8859-1", ...
private mSupportedComponents ' Array of CxMailComponent
private mMailComponent ' CxMailComponent
private mMailer
private mMailerId
property get SupportedComponents()
' returns array of CxMailComponent (read only!)
SupportedComponents = mSupportedComponents
end property
property get MailComponent()
' returns current used CxMailComponent (read only!)
set MailComponent = mMailComponent
end property
private sub Class_Initialize()
MailHost = ""
Port = 25
PickupFolder = "c:\Inetpub\mailroot\Pickup"
Queue = true
UserName = ""
Password = ""
FromAddr = ""
FromName = ""
Subject = ""
Body = ""
AltBody = ""
IsHtml = false
CharSet = "utf-8"
set mMailer = Nothing
set mMailComponent = Nothing
mSupportedComponents = CheckSupportedComponents()
mMailerId = CxMailerNoneId
end sub
private sub Class_Terminate()
set mMailer = Nothing
end sub
function IsAvailable()
' returns true if selected Mail-Component is available
IsAvailable = false
if mMailerId <> CxMailerNoneId then
IsAvailable = mSupportedComponents(mMailerId).IsAvailable
end if
end function
sub ClearRecipients()
if mMailerId = CxMailerCdosysId then
mMailer.ClearRecipients
elseif mMailerId = CxMailerPersitsId then
mMailer.Reset
end if
end sub
sub ClearAll()
ClearRecipients
FromAddr = ""
FromName = ""
Subject = ""
Body = ""
IsHtml = false
end sub
function SelectComponent( aMailHost, aComponentName )
' aMailHost: DNS to mail host (e.g. "mail.mydomain.com")
' aComponentName: "CDONTS", "CDOSYS", "Persits", ""
' use "" to autoselect first available component
' returns true, if desired component is available
' reset all
set mMailer = Nothing
mMailerId = CxMailerNoneId
set mMailComponent = Nothing
ClearAll
MailHost = aMailHost
PickupFolder = "c:\inetpub\mailroot\pickup"
Queue = true
if aComponentName = "" then
mMailerId = FindFirstAvailableComponent()
else
mMailerId = FindComponent( aComponentName )
end if
if mMailerId >= 0 then
set mMailComponent = mSupportedComponents(mMailerId)
end if
SelectComponent = false
if not mMailComponent is Nothing then
SelectComponent = mMailComponent.IsAvailable
end if
' create mailer object now to pass other calls to it
if SelectComponent then
if mMailerId = CxMailerCdosysId then
set mMailer = new CCdosysMail
elseif mMailerId = CxMailerPersitsId then
set mMailer = Server.CreateObject(mMailComponent.ClassName)
end if
else
mMailerId = CxMailerNoneId
end if
end function
sub AddTo( aToAddr, aToName )
if mMailerId = CxMailerCdosysId then
mMailer.AddTo aToAddr, aToName
elseif mMailerId = CxMailerPersitsId then
mMailer.AddAddress aToAddr, mMailer.EncodeHeader(aToName, CharSet)
end if
end sub
sub AddCc( aCcAddr, aCcName )
if mMailerId = CxMailerCdosysId then
mMailer.AddCc aCcAddr, aCcName
elseif mMailerId = CxMailerPersitsId then
mMailer.AddCc aCcAddr, mMailer.EncodeHeader(aCcName, CharSet)
end if
end sub
sub AddBcc( aBccAddr, aBccName )
if mMailerId = CxMailerCdosysId then
mMailer.AddBcc aBccAddr, aBccName
elseif mMailerId = CxMailerPersitsId then
mMailer.AddBcc aBccAddr, mMailer.EncodeHeader(aBccName, CharSet)
end if
end sub
sub Send()
' check availability of component before!
on error resume next
if mMailerId = CxMailerCdosysId then
mMailer.MailHost = MailHost
mMailer.Port = Port
mMailer.PickupFolder = PickupFolder
mMailer.Queue = Queue
mMailer.UserName = UserName
mMailer.Password = Password
mMailer.FromAddr = FromAddr
mMailer.FromName = FromName
mMailer.Subject = Subject
mMailer.Body = Body
if IsHtml then
' make alternativ text body and send as multipart
if Len(AltBody) = 0 then
mMailer.AltBody = ConvertHtmlToText(Body)
else
mMailer.AltBody = AltBody
end if
else
mMailer.AltBody = ""
end if
mMailer.IsHtml = IsHtml
mMailer.Send
elseif mMailerId = CxMailerPersitsId then
mMailer.CharSet = CharSet
mMailer.Host = MailHost
mMailer.Port = Port
mMailer.Queue = Queue
mMailer.Username = UserName
mMailer.Password = Password
mMailer.From = FromAddr
mMailer.FromName = mMailer.EncodeHeader(FromName, CharSet)
mMailer.Subject = mMailer.EncodeHeader(Subject, CharSet)
mMailer.Body = Body
if IsHtml then
' make alternativ text body and send as multipart
if Len(AltBody) = 0 then
mMailer.AltBody = ConvertHtmlToText(Body)
else
mMailer.AltBody = AltBody
end if
else
mMailer.AltBody = ""
end if
mMailer.IsHtml = IsHtml
mMailer.Send
end if
end sub
sub QuickSend( aFrom, aTo, aSubject, aBody )
ClearAll
FromAddr = aFrom
AddTo aTo, ""
Subject = aSubject
Body = aBody
Send
end sub
private function CheckSupportedComponents()
dim compList(1), comp
' check CDOSYS
set comp = new CxMailComponent
comp.Name = "CDOSYS"
comp.ClassName = "CDO.Message"
comp.IsAvailable = IsComponentInstalled(comp.ClassName)
comp.DocUrl = "http://msdn.microsoft.com/en-us/library/aa139781.aspx"
set compList(CxMailerCdosysId) = comp
' check Persits
set comp = new CxMailComponent
comp.Name = "Persits"
comp.ClassName = "Persits.MailSender"
comp.IsAvailable = IsComponentInstalled(comp.ClassName)
comp.DocUrl = "http://www.aspemail.com/manual.html"
set compList(CxMailerPersitsId) = comp
CheckSupportedComponents = compList
end function
private function FindComponent( aComponentName )
dim i
for i = 0 to UBound(mSupportedComponents)
if StrComp(mSupportedComponents(i).Name, aComponentName, 1) = 0 then
FindComponent = i
exit function
end if
next
FindComponent = CxMailerNoneId
end function
private function FindFirstAvailableComponent()
dim i
for i = 0 to UBound(mSupportedComponents)
if mSupportedComponents(i).IsAvailable then
FindFirstAvailableComponent = i
exit function
end if
next
FindFirstAvailableComponent = CxMailerNoneId
end function
private function IsComponentInstalled( aClassName )
dim mailComp
on error resume next
set mailComp = Server.CreateObject(aClassName)
IsComponentInstalled = (Err = 0)
set mailComp = Nothing
Err.Clear
end function
function ConvertHtmlToText( aStr )
' Note: works only for not nested lists and tables
dim s, nl, nlnl, sp, snl, tab
tab = Chr(9)
nl = Chr(1)
nlnl = nl&nl
snl = Chr(2)
sp = Chr(3)
s = aStr
' keep linebreaks and blanks in <pre> tags
s = ReplaceWithinPattern( s, "(<pre[^>]*>[^\0]*?</pre>)", vbCRLF, snl, true )
s = ReplaceWithinPattern( s, "(<pre[^>]*>[^\0]*?</pre>)", " ", sp, true )
' make line breakes and tabs to spaces
s = Replace( s, vbCRLF, " " )
s = Replace( s, "\n", " " )
s = Replace( s, "\r", " " )
s = Replace( s, "\t", " " )
' remove header, scripts, styles
s = ReplacePattern( s, "< *", "<", false )
s = ReplacePattern( s, " *>", ">", false )
s = ReplacePattern( s, "<head[^>]*>[^\0]*?</head>", "", true )
s = ReplacePattern( s, "<script[^>]*>[^\0]*?</script>", "", true )
s = ReplacePattern( s, "<style[^>]*>[^\0]*?</style>", "", true )
' replace <td> and <th> with |
s = ReplacePattern( s, "<tr[^>]*> *<t[dh][^>]*>", nl, true )
s = ReplacePattern( s, "<t[dh][^>]*>", " ", true )
' replace <tr>, <br> with NL
s = ReplacePattern( s, "<tr[^>]*>", nl, true )
s = ReplacePattern( s, "<br[^>]*>", nl, true )
' replace <li>, <dd> with NL *
s = ReplacePattern( s, "<li[^>]*>", nl&"* ", true )
s = ReplacePattern( s, "<dd[^>]*>", nl, true )
' replace <hx>, <p>, <pre>, <div>, <table>, <ol>, <ul>, <dl> with NL NL
s = ReplacePattern( s, "<h[12][^>]*>", nlnl&"-------"&nlnl, true )
s = ReplacePattern( s, "</?h\d[^>]*>", nlnl, true )
s = ReplacePattern( s, "<p[^>]*>", nlnl, true )
s = ReplacePattern( s, "<pre[^>]*>", nlnl, true )
s = ReplacePattern( s, "<div[^>]*>", nlnl, true )
s = ReplacePattern( s, "<table[^>]*>", nlnl, true )
s = ReplacePattern( s, "<[oud]l[^>]*>", nlnl, true )
' handle links
s = ReplacePattern( s, "<a [^>]*href=""?((http|mailto)[^"" >]*)[^>]*>(\1)</a>", "[$1]", true )
s = ReplacePattern( s, "<a [^>]*href=""?((http|mailto)[^"" >]*)[^>]*>([^\0]*?)</a>", "$3 [$1]", true )
' remove all tags
s = ReplacePattern( s, "<[^>]*>", "", false )
' replace special chars
s = Replace( s, "<", "<" )
s = Replace( s, ">", ">" )
s = Replace( s, " ", " " )
s = Replace( s, "&", "&" )
s = ReplacePattern( s, "&.{2,6};", "", false )
' remove extra spaces and line breaks
s = Trim( s )
s = ReplacePattern( s, "\x01 +", nl, false )
s = ReplacePattern( s, " +\x01", nl, false )
s = ReplacePattern( s, " {2,}", " ", false )
s = ReplacePattern( s, "\x01{3,}", nlnl, false )
' Trim NL
s = ReplacePattern( s, "^\x01*([^\0]*?)\x01*$", "$1", false )
s = ReplacePattern( s, "\x01", vbCRLF, false )
' finish
s = Replace( s, sp, " " )
s = Replace( s, snl, vbCRLF )
if Len(s) > 0 then s = s & vbCRLF
ConvertHtmlToText = s
end function
end class
%>