Mensaje enviado por "Jose A. P. S." <japs73vb@hotmail.com> el 27/12/2002


Hola,
   Este código es el que yo utilizo para enviar correos mendiante MAPI, esta
muy probado ya que lo utilizo para mailing.

   Espero que te sirva. FELIZ NAVIDAD.

Jose

------------------------------

Public Sub AbrirMAPISession()
    On Error GoTo AbrirMAPISession_Error

    Screen.MousePointer = vbHourglass

    MensajeEstadoGeneral "Abriendo Sesión de Correo..."
    If MAPISession1.SessionID = 0 Then
          'download new mail = false
          MAPISession1.DownLoadMail = False
          'show the logon interface for the mail
          'account = true
          MAPISession1.LogonUI = True
          'sign on to selected account
          MAPISession1.SignOn
    End If
    MensajeEstadoGeneral

    Screen.MousePointer = vbDefault

    GoSub AbrirMAPISession_Exit
    Exit Sub

AbrirMAPISession_Exit:
    On Error Resume Next
    ChDrive App_Path
    ChDir App_Path
    Return

AbrirMAPISession_Error:
    MsgBox Err.Description, vbExclamation, "Sesión de Correo"
    MensajeEstadoGeneral
    GoSub AbrirMAPISession_Exit
End Sub

Public Function EnviarMAPIMail(MsgTo As String, Optional CC As String = "",
Optional BCC As String = "", Optional Subject As String = "", Optional Body
As String = "", Optional Att As String = "", Optional NombreFicheros As
String, Optional ExtensionFicheros As String) As Boolean

    On Error GoTo EnviarMAPIMail_Error

    AbrirMAPISession

    If MAPISession1.SessionID = 0 Then
        MsgBox "Error al abrir la sesión de correo.", vbCritical, "Sesión de Correo (MAPI)"
        GoSub EnviarMAPIMail_Exit
        Exit Function
    End If
    Screen.MousePointer = vbHourglass

    'set the session IDs the same on both objects
    With MAPIMessages1
        MensajeEstadoGeneral "Creando mensaje de correo..."
        .SessionID = MAPISession1.SessionID

        'Set the MSgIndex to -1, this needs to be
        'done for the Compose event to work
        .MsgIndex = -1
        'compose a new message
        .Compose

        'don't show the resolve address interface
        .AddressResolveUI = False

        MAPIDestinatarios MsgTo

        MAPIDestinatarios CC, mapCcList
        MAPIDestinatarios BCC, mapBccList

        'set the subject
        .MsgSubject = Subject

        'set the Message/Body/NoteText
        .MsgNoteText = Body

        If Att <> "" Then
            'set an attachment
            MensajeEstadoGeneral "Adjuntando archivos al mensaje de correo..."
            MAPIArchivosAdjuntos Att, NombreFicheros, ExtensionFicheros
        End If



        'send the message
        MensajeEstadoGeneral "Enviando mensaje de correo..."
        .Send
    End With
    MensajeEstadoGeneral

    EnviarMAPIMail = True

    Screen.MousePointer = vbDefault
    GoSub EnviarMAPIMail_Exit
    Exit Function

EnviarMAPIMail_Exit:
    On Error Resume Next
    ChDrive App_Path
    ChDir App_Path
    Return

EnviarMAPIMail_Error:
    Screen.MousePointer = vbDefault
    MsgBox Err.Description, vbExclamation, "Sesión de Correo"
    MensajeEstadoGeneral
    GoSub EnviarMAPIMail_Exit
End Function

Private Sub MAPIDestinatarios(Destinatarios As String, Optional TipoDest As
RecipTypeConstants = mapToList)
    Dim Dest() As String
    Dim nd As Long


    If Len(Destinatarios) Then
        Dest = Split(Destinatarios, ";")

        For nd = LBound(Dest) To UBound(Dest)
            'set the recipient
            MAPIMessages1.RecipIndex = MAPIMessages1.RecipCount
            MAPIMessages1.RecipType = TipoDest
            MAPIMessages1.RecipAddress = Trim(Dest(nd))
            'resolve the recipient's email addresses

            MAPIMessages1.ResolveName
        Next nd
    End If
End Sub

Private Sub MAPIArchivosAdjuntos(ArchivosAdjuntos As String, Optional NombreFicheros As String, Optional ExtensionFicheros As String)
    Dim Arch() As String
    Dim na As Long
    Dim NameFich As String

    If Len(ArchivosAdjuntos) Then
        Arch = Split(ArchivosAdjuntos, ";")

        For na = LBound(Arch) To UBound(Arch)
            'set the recipient
            If Len(Trim(Arch(na))) Then
                If Dir(Trim(Arch(na)), vbArchive) <> "" Then
                    With MAPIMessages1
                        If Len(.MsgNoteText) < na + 1 Then
                            .MsgNoteText = .MsgNoteText + " "
                        End If
                        .AttachmentIndex = MAPIMessages1.AttachmentCount
                        .AttachmentPosition = MAPIMessages1.AttachmentIndex
                        If Len(NombreFicheros) Then
                            NameFich = NombreFicheros & CStr(na + 1)
                            If Len(ExtensionFicheros) Then
                                NameFich = NameFich & "." & ExtensionFicheros
                            End If
                            .AttachmentName = NameFich
                        End If
                        .AttachmentPathName = Trim(Arch(na))
                    End With
                End If
            End If
        Next na
    End If
End Sub