WaBis

walter.bislins.ch

Datei: xmail.inc

Inhalt der Datei: ./asp/xmail/xmail.inc
<!--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, "&lt;", "<" )
    s = Replace( s, "&gt;", ">" )
    s = Replace( s, "&nbsp;", " " )
    s = Replace( s, "&amp;", "&" )
    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
%>
Weitere Infos zur Seite
Erzeugt Dienstag, 18. Oktober 2011
von wabis
Zum Seitenanfang
Geändert Freitag, 13. April 2012
von *System*