[Resolvido] envio de newsletter

[xanburzum 169]

A lógica é a seguinte, atraves de um banco com todos destinatários.

, é criado uma página que contem exatamente o corpo da minha news.Utilizando o objeto Microsoft.XMLHTTP capturo o código fonte (HTML) desta página e guardo em uma variável,em seguida faço um loop no banco de destinatários e envio, utilizando CDOSYS, o conteúdo da variável acima como corpo da mensagem. É importante lembrar que o CDOSYS deve ser aberto, usado e fechado a cada envio...

 

Para capturar o código fonte utilizo a seguinte função:

 

Function GetHTML(sPage)

' *** exemplo de uso: GetHTML("http://www.teste.com/var_xanburzum_Paypal/default.asp")
' *** sPage = onde passamos o enderço completo da página a ser carregada
Dim objXMLHttp
On Error Resume Next
Set objXMLHttp = Server.CreateObject ("Microsoft.XMLHTTP")
objXMLHttp.Open "GET", sPage, False
objXMLHttp.Send
If Err.Number = 0 Then
If objXMLHttp.Status = 200 then
GetHTML = objXMLHttp.ResponseText
Else
GetHTML = "URL Incorrecta"
End if
Else
GetHTML = Err.Description
End If
Set objXMLHttp = Nothing
End Function

Para enviar e-mail sugiro esta função:

 

Function EnviaMail(strTo, strFrom, strSubject, strBody, blnBodyHTML, strServer)
' *** Envia mengagem de email utilizando CDOSYS que está disponível desde o Windows 2000 server
' *** strTo = email de destino
' *** strFrom = email de origem
' *** strSubject = Assunto da mensagem
' *** strBody = corpo da mensagem
' *** blnBodyHtm = true se for HTML - false se texto
' *** strServer = servidor SMTP para envio de email (o default é "")

Dim iMsg, Flds, iConf
Dim strSMTPServer

if strServer = "" then
strSMTPServer = "localhost"
else
strSMTPServer = StrServer
end if

Set iMsg = CreateObject("CDO.Message")
Set iConf = CreateObject("CDO.Configuration")
Set Flds = iConf.Fields

With Flds
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 '1=cdoSendUsingPickup 2=cdoSendUsingPort 
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = strSMTPServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0 '0=anonimo e 1=usuário e senha
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport")= 25
.Update
End With

With iMsg
Set .Configuration = iConf
.To = strTo
.From = strFrom
.Sender = strFrom
.Subject = strSubject
If blnBodyHTML Then
.HTMLBody = strBody
Else
.TextBody = strBody
End If
.Send
End With

Set Flds = Nothing
Set iConf = Nothing
Set iMsg = Nothing
End Function