Veja se isso ajuda
'Procedimento adaptado por Lindolfo de Araujo Filho
'Este procedimento usa a própria dll do OutlookExpress,
'por isso não precisa de componentes.
'Se o Outlook estiver selecionado a segurança como
'"Avisar quando outro aplicativo tentar enviar email como se fosse eu"
'então aparecerá um alerta pedindo a permissão para enviar,
'o que nào causa problema algum.
Em um Módulo
********************************************************************************************
Option Explicit
Type MAPIMessage
Reserved As Long
Subject As String
NoteText As String
MessageType As String
DateReceived As String
ConversationID As String
Flags As Long
RecipCount As Long
FileCount As Long
End Type
Type MapiRecip
Reserved As Long
RecipClass As Long
Name As String
Address As String
EIDSize As Long
EntryID As String
End Type
Type MapiFile
Reserved As Long
Flags As Long
Position As Long
PathName As String
FileName As String
FileType As String
End Type
'*********************************************************************************
'Altere aqui o caminho da dll MSOE.DLL de acordo com o seu micro
'*********************************************************************************
Declare Function MAPISendMail Lib "C:Arquivos de programasOutlook ExpressMsoe.dll" _
Alias "BMAPISendMail" _
(ByVal Session&, ByVal UIParam&, Message As MAPIMessage, _
Recipient() As MapiRecip, File() As MapiFile, ByVal Flags&, _
ByVal Reserved&) As Long
Global Const SUCCESS_SUCCESS = 0
Global Const MAPI_TO = 1
Global Const MAPI_CC = 2
Global Const MAPI_CCO = 3
Global Const MAPI_LOGON_UI = &H1
Function CountTokens(ByVal sSource As String, ByVal sDelim As String)
Dim iDelimPos As Integer
Dim iCount As Integer
If sSource = "" Then
CountTokens = 0
Else
iDelimPos = InStr(1, sSource, sDelim)
Do Until iDelimPos = 0
iCount = iCount + 1
iDelimPos = InStr(iDelimPos + 1, sSource, sDelim)
Loop
CountTokens = iCount + IIf(Right(sSource, 1) = sDelim, 0, 1)
End If
End Function
Function GetToken(sSource As String, ByVal sDelim As String) As String
Dim iDelimPos As Integer
' Busca el primer delimitador
iDelimPos = InStr(1, sSource, sDelim)
If (iDelimPos = 0) Then
GetToken = Trim$(sSource)
sSource = ""
Else
GetToken = Trim$(Left$(sSource, iDelimPos - 1))
sSource = Mid$(sSource, iDelimPos + 1)
End If
End Function
Sub ParseTokens(mArray() As String, ByVal sTokens As String, ByVal sDelim As String)
Dim i As Integer
For i = LBound(mArray) To UBound(mArray)
mArray(i) = GetToken(sTokens, sDelim)
Next
End Sub
' PARAMETROS:
' sSubject: Es texto que aparecerá como Asunto del mensaje
' sTo: Lista delimitada por ";" com os destinatários da mensagem.
' sCC: Lista dos destinatários CC (Copia)
' sCCO: Lista dos destinatários CCO (Copia oculta)
' sAttach: Lista dos anexos a enviar
Function SendMail(sSubject As String, sTo As String, sCC As String, sCCO As String, _
sAttach As String, sMessage As String)
On Error GoTo Err_CapturarError
Dim i, cTo, cCC, cCCO, cAttach ' contadores de items
Dim MAPI_Message As MAPIMessage
' Contar el número de items en cada lista
cTo = CountTokens(sTo, ";")
cCC = CountTokens(sCC, ";")
cCCO = CountTokens(sCCO, ";")
cAttach = CountTokens(sAttach, ";")
' Dimensionar las matrices para las listas
ReDim rTo(0 To cTo) As String
ReDim rCC(0 To cCC) As String
ReDim rCCO(0 To cCCO) As String
ReDim rAttach(0 To cAttach) As String
' Pasar el contenido de las listas a las matrices
ParseTokens rTo(), sTo, ";"
ParseTokens rCC(), sCC, ";"
ParseTokens rCCO(), sCCO, ";"
ParseTokens rAttach(), sAttach, ";"
' Crear la estructura MAPI Recip para almacenar todos los destinatarios
ReDim MAPI_Recip(0 To cTo + cCC + cCCO - 1) As MapiRecip
' Cargar los "TO:" en la estructura
For i = 0 To cTo - 1
MAPI_Recip(i).Name = rTo(i)
MAPI_Recip(i).RecipClass = MAPI_TO
Next i
' Cargar los "CC:"
For i = 0 To cCC - 1
MAPI_Recip(cTo + i).Name = rCC(i)
MAPI_Recip(cTo + i).RecipClass = MAPI_CC
Next i
' Cargar los "CCO:"
For i = 0 To cCCO - 1
MAPI_Recip(cTo + cCC + i).Name = rCCO(i)
MAPI_Recip(cTo + cCC + i).RecipClass = MAPI_CCO
Next i
' Crear la estructura MAPI_File para los adjuntos
ReDim MAPI_File(0 To cAttach) As MapiFile
' Cargar los adjuntos en la estructura
MAPI_Message.FileCount = cAttach
For i = 0 To cAttach - 1
MAPI_File(i).Position = -1
MAPI_File(i).PathName = rAttach(i)
Next i
' Llenar los campos del mensaje
MAPI_Message.Subject = sSubject
MAPI_Message.NoteText = sMessage
MAPI_Message.RecipCount = cTo + cCC + cCCO
' Enviar el mensaje
SendMail = MAPISendMail(0&, 0&, MAPI_Message, MAPI_Recip(), _
MAPI_File(), MAPI_LOGON_UI, 0&)
Salida:
Exit Function
Err_CapturarError:
Select Case Err.Number
Case 48
'Error: No se encontró el archivo: C:Archivos de programa _
Outlook ExpressMsoe.dll
SendMail = 48
Case 453
'Error: Imposible encontra el punto de entrada de DLL BMAPISendMail en _
MAPI32X.DLL
'Asignar el número de error. El filtro y el mensaje más adelante.
SendMail = 453
Case Else
'Cazar todos aquellos errores inesperados.
MsgBox Err.Number & " " & Err.Description
End Select
Resume Salida 'Salida a otro procedimiento.
End Function
No Controle Desejado
********************************************************************************************
On Error GoTo sai
Dim lngRet As Long
'Envia a mensagem
lngRet = SendMail(("ASSUNTO"), ("
destinatario@para"), ("
destinatario@comcopia"), ("
destinatario@comcopiaoculta"), ("C:AraujoAnexo.txt"), ("TEXTO DA MENSAGEM"))
Exit Sub
sai:
'Se ocorrer erro
If lngRet <> SUCCESS_SUCCESS Then
Select Case lngRet
Case 2
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "Verifique a origem do arquivo anexado. ", vbCritical, "ERRO"
Case 48
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "Não foi possível carregar MSOE.DLL", 16, "ERRO"
Case 453
MsgBox "Error nº.: " & lngRet & " (de MSAccess), ao enviar email." _
& vbCr & vbCr _
& "MAPI32X.DLL, não é a versão correta.", vbCritical, "ERRO"
Case -2147467259
MsgBox "Error nº.: " & lngRet & ", ao enviar email." & vbCr & vbCr _
& "MAPI32.DLL, não é a versão correta.", vbCritical, "ERRO"
Case Else
MsgBox "Erro ao enviar email: " & lngRet, vbCritical, "ERRO"
End Select
End If
