# =Enviar mail con archivos adjuntos=



## yra_vj (Nov 26, 2007)

Hola que tal!  

Alguien podria ayudarme en como crear una macro para poder enviar desde una hoja en excel que tengo de "control" un mail con archivos adjuntos. 

Intente hacerlo atravez de grabar la macro paso a paso eligiendo directamente de el menu ARCHIVO,ENVIAR A,DESTINATARIO DE CORREO (como archivos adjuntos)pero el resultado del codigo no me ha sido de  mucha ayuda,espero me puedan orientar, de antemano muchas gracias por su ayuda! :wink:


----------



## Greg Truby (Nov 26, 2007)

¿A cuántas personas está mandando los correos-e?


----------



## yra_vj (Nov 26, 2007)

*No de personas*

El mail es para tres personas, en el mail debo de adjuntar 4 archivos


----------



## Greg Truby (Nov 27, 2007)

Bueno,

Aquí pongo una rutina que uso mensualmente para mandar encuestas.  Utiliza varios cuadernos y hace poco empezó a fallar al agarrar un rango nombrado por eso empecé a usar una manera más complicada para sacar el rango que es un listado de nombres.  Este código controla Outlook.  Lo que hago es usar .DISPLAY para crear un correo y mostrar lo primero.  Eso me da chance de revisar cada mensaje y el anexo para asegurar que todo está en orden antes de enviarlos.  Espero que le ayude:

```
'¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯¯
Sub EMailSurveys()
'______________________________________________________________________________

' Code here assumes that ThisWorkbook is located in a directory
' named ..\yyyy mm\
    
    Dim wbInterface As Workbook
    Dim rngEMails As Range, rngCell As Range, rngNPCs As Range, rngMsg As Range
    Dim strPS As String, strPath As String, strBranch As String, _
        strFileName As String, strEmailMsg As String
    Dim namAddresses As Name, namMessage As Name
    Dim miNew As Outlook.MailItem
    Dim objRecipient As Outlook.Recipient
    Dim objCC As Outlook.Recipient
    Dim objAttachment As Outlook.Attachment
    Dim appOL As Outlook.Application
    Dim lngClickYes As Long, lngWnd As Long, lngResponse As Long
    Dim booIOpenedInterface As Boolean

    ' ______Get list of NPC's, e-mail addresses & e-mail
    '       message from Interface workbook_____
    On Error Resume Next
    Set wbInterface = Workbooks("Interface.xls")
    Err.Clear
    On Error GoTo ErrorNoInterface
    If wbInterface Is Nothing Then
        Set wbInterface = Workbooks.Open(gc_strMainPath & "Interface.xls")
        booIOpenedInterface = True
    Else
        booIOpenedInterface = False
    End If
    
    Set namAddresses = wbInterface.Names("EmailAddresses")
    Set rngEMails = wbInterface.Worksheets(WSNameFromAddress(namAddresses.RefersTo)).Range(AddrFromLongAddr(namAddresses.RefersTo))
    
    Set namMessage = wbInterface.Names("EmailMessage")
    Set rngMsg = wbInterface.Worksheets(WSNameFromAddress(namMessage.RefersTo)).Range(AddrFromLongAddr(namMessage.RefersTo))
    strEmailMsg = rngMsg.Text
    Set rngNPCs = rngEMails.Columns(1)
    
    ' ______set up other needed variables______
    'Set appXL = Application
    Set appOL = Outlook.Application
    strPS = Application.PathSeparator
    strPath = ThisWorkbook.Path
    strBranch = HighestPathBranch(strPath)
    If Right(strPath, 1) <> strPS Then strPath = strPath & strPS
    
    ' +---------------------------------------------------+
    ' | Nov 2003: the CLICKYES applet no longer needed    |
    ' | with OUTLOOK 2003 for you don't get the           |
    ' | annoying popup dialog for each message.           |
    ' +---------------------------------------------------+
'    '  _____Register a message to send_____                             --------+
'    lngClickYes = RegisterWindowMessage("CLICKYES_SUSPEND_RESUME") '            |
'    '                                                                           |
'    '  _____Find ClickYes Window by ClassName_____                              |
'    lngWnd = FindWindow("EXCLICKYES_WND", 0&) '                                 |===> For ClickYes Applet
'    '                                                                           |
'    '  _____Send the message to Resume ClickYes_____                            |
'    lngResponse = SendMessage(lngWnd, lngClickYes, 1, 0) '              --------+

    ' _____Create mail items and send 'em out.______
    For Each rngCell In rngNPCs.Cells
        If IsEmpty(rngCell.Offset(, 1)) Then GoTo FinDelAro
        strFileName = "TAT Survey - " & strBranch & " - " & rngCell & ".xls"
        ' _____No file - skip to next_____
        If Dir(strPath & strFileName) = "" Then GoTo FinDelAro
        
        Application.StatusBar = "Creating mail item for " & rngCell
        Set miNew = appOL.CreateItem(olMailItem)
        With miNew
            Set objRecipient = .Recipients.Add(rngCell.Offset(, 1).Value)
            objRecipient.Type = OlMailRecipientType.olTo
            If Not IsEmpty(rngCell.Offset(, 2)) Then
                Set objCC = .Recipients.Add(rngCell.Offset(, 2).Value)
                objCC.Type = OlMailRecipientType.olCC
            End If
            .Subject = "TAT Survey / Encuesta de TAT [" & strBranch & "] [" & rngCell & "]"
            .Body = strEmailMsg
            Set objAttachment = .Attachments.Add(strPath & strFileName)
            For Each objRecipient In .Recipients
                objRecipient.Resolve
            Next objRecipient
            .Display
        End With

FinDelAro:
'"""""""""
    Next rngCell
    
    '  _____Send the message to Suspend ClickYes_____
    'lngResponse = SendMessage(lngWnd, lngClickYes, 0, 0)
    
    Application.StatusBar = False
    
    If booIOpenedInterface Then wbInterface.Close
    Set wbInterface = Nothing
    Set appOL = Nothing
    Exit Sub
        
ErrorNoInterface:
'""""""""""""""""

    MsgBox "Unable to find/open Interface workbook.", vbExclamation, "Critical Error"

End Sub
```


----------



## yra_vj (Nov 29, 2007)

*Gracias!!*

Gracias por el codigo brindado, lo revisare y pondre en practica, cualquier cosa, nos manetemos en contacto,gracias Greg!!

Saludos!


----------

