O uso do CDO para envio de mensagem exige qua a biblioteca "cdosys.dll" esteja presente no equipamento ; pode ser que seja por isso:
Ao executar o codigo proposto pelo colega Morel execute tb o trecho, conforme abaixo para saber se a biblioteca está disponivel:
Sub EMail()
Dim msgf As String
Dim lngCDORet As Long
lngCDORet = LoadLibrary("cdosys.dll") 'biblioteca do CDO
If lngCDORet = 0 Then
MsgBox "CDOSys.DLL não encontrada. Abortando..."
exit sub
end if
'Configurando os dados do E-mail
End If
Segue tambem o codigo similar ao postado pelo colega Morel, com alguns comentários, pode ser que lhe auxilie
Obs.: Baseado no codigo distribuido pelo colega Alexel no forum ExcelBr (YahooGropups)
Option Explicit
Public Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
Sub fnSendCDOMail()
'This code is slightly more complex but not very difficult to understand or work with.
Dim objMessage As Object
Dim lngCDORet As Long, daev, pev, tpev, tsev
pev = ActiveSheet.Range("AA1").Value
daev = ActiveSheet.Range("AA11").Value
tpev = ActiveSheet.Range("AA3").Value
tsev = ActiveSheet.Range("AA2").Value
Const cdoSendUsingPickup = 1 'Send message using the local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using the network (SMTP over the network).
Const cdoAnonymous = 0 'Do not authenticate
Const cdoBasic = 1 'basic (clear-text) authentication
Const cdoNTLM = 2 'NTLM
lngCDORet = LoadLibrary("cdosys.dll") 'biblioteca do CDO
If lngCDORet = 0 Then
MsgBox "CDOSys.DLL não encontrada. Abortando..."
GoTo lblExit
End If
Set objMessage = CreateObject("CDO.Message")
objMessage.Subject = tsev '"CDO - Exemplo de envio de mensagem"
objMessage.From = daev '"""Ed"" <ecotait@hotmail.com>" 'troque
objMessage.To = pev 'por favor, troque. Se for utilizar mais de um e-Mail, separe-os com ponto-e-vírgula
'objMessage.cc = "" '"alexcel@...; cooorrea@..." 'por favor, troque
'objMessage.BCC = "" '"alexcel@..." 'por favor, troque
objMessage.TextBody = tpev ' "Texto da mensagem..." & vbCrLf & "Foi utilizada a autenticação por SMTP(CDO)." & vbCrLf & Now()
'Caso queira enviar o escudo do Galo como anexo, posso lhe disponibilizar o arquivo…
' objMessage.AddAttachment "c:EscudoDoGalo.jpg"
'==This section provides the configuration information for the remote SMTP server.
'Configurações hard-coded para o Yahoo.Com.Br
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
'Name or IP of Remote SMTP Server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.mail.yahoo.com.br"
'Type of authentication, NONE, Basic (Base64 encoded), NTLM
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
'Your UserID on the SMTP server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendusername") = "reinaldomarco"
'Your password on the SMTP server
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/sendpassword") = InputBox("Senha:") 'altere a forma de passar esta senha, caso deseje envio em massa utilizando Loop.
'Server port (typically 25)
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
'Use SSL for the connection (False or True)
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
'Connection Timeout in seconds (the maximum time CDO will try to establish a connection to the SMTP server)
objMessage.Configuration.Fields.Item _
("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 60
objMessage.Configuration.Fields.Update
'==End remote SMTP server configuration section==
objMessage.Send
lblExit:
On Error Resume Next
FreeLibrary lngCDORet
On Error GoTo 0
Exit Sub
End Sub
Postado : 05/03/2013 1:05 pm