Saltar al contenido

Enviar email con dos cuentas. (modificar macro)


Recommended Posts

Buenas tardes Gente, Queria consultar lo siguiente, tengo una macro que me permite enviar mails desde excel a outlook. Esta macro que por cierto funciona de 10!! y que la encontre en este foro me sirve mucho ya que permite enviar mails con formato (negrita, links, imagenes, color, etc...) todo marcha bien pero lo que ahora necesito es que me permita enviar el mismo mail dos veces pero con distinta cuenta.

Es decir necesito enviar el mismo mail dos veces a un destinatario; una con la cuenta de gmail y otra con hotmail. Ambas cuentas ya las tengo configuradas en outlook por lo que solo habria que modificar la rutina para incluir el cambio de perfil y que envie estos dos mails al mismo tiempo.

El codigo de esta macro es:

Option Explicit
Private Sub CommandButton1_Click()
Dim xAplicacion As Object
Dim xMail As Object
Dim wd As Object
Dim doc As Object
Dim itm As Object
Dim ID As String
Dim xTo As String
Dim xSub As String
Dim xArc As String
Dim xCC As String
Dim xArchivo As String
Dim xCuerpo As String
Dim OpWord As Boolean
Dim HayWord As Boolean
Dim Celda As Range
Dim MyRango As Range
Dim i As Long
Dim Ucol As Long
Dim Inicio
Dim Pausa
On Error Resume Next

i = Range("C" & Rows.Count).End(xlUp).Row
Ucol = Cells(1, Columns.Count).End(xlToLeft).Column
Columns(Ucol).ClearContents
Cells(1, Ucol) = "Enviado"

Set MyRango = Range("B2:B" & i)
Set xAplicacion = CreateObject("Outlook.Application")

For Each Celda In MyRango
OpWord = False
ID = ""
If UCase(Celda) = "X" Then
xTo = Range("C" & Celda.Row)
xSub = Range("D" & Celda.Row)
xArc = Range("E" & Celda.Row)
If UCase(Range("F" & Celda.Row)) = "X" Then
Set wd = CreateObject("Word.Application")
If Not wd Is Nothing Then OpWord = True
Set doc = wd.Documents.Open(Filename:=xArc, ReadOnly:=True)
Set itm = doc.MailEnvelope.Item
With itm
.To = xTo
.Subject = xSub
For i = 5 To Ucol - 1
If Celda.Offset(0, i) <> Empty Then
xArchivo = Celda.Offset(0, i).Value
.Attachments.Add xArchivo, olByValue
End If
Next i
.Save
ID = .EntryID
End With
Set itm = Nothing
Set itm = xAplicacion.Session.GetItemFromID(ID)
itm.Send
doc.Close False
If OpWord Then
wd.Quit
End If
Else
Set xMail = xAplicacion.CreateItem(olMailItem)
On Error Resume Next
xCuerpo = Range("E" & Celda.Row)
With xMail
.To = xTo
xCC = xAplicacion.Session.Accounts.Item(1)
.CC = xCC
.BCC = ""
.Subject = xSub
.Body = xCuerpo
For i = 5 To Ucol - 1
If Celda.Offset(0, i) <> Empty Then
xArchivo = Celda.Offset(0, i).Value
.Attachments.Add xArchivo, olByValue
End If
Next i
.Send
End With
Set xMail = Nothing
End If
Inicio = Timer
Do While Timer < Inicio + Pausa
DoEvents
Loop
If Err.Number = 0 Then
Celda.Offset(0, Ucol - 2) = "Enviado"
Else
Celda.Offset(0, Ucol - 2) = "Error?"
End If
On Error GoTo 0
End If
Next Celda
Set doc = Nothing
Set itm = Nothing
Set wd = Nothing
Set MyRango = Nothing
Set xAplicacion = Nothing
MsgBox "Proceso Finalizado", , ""
End Sub

[/CODE]

Adjunto tambien un rar con el excel y la macro incluida que la saque de este excelente foro. Ojala me puedan ayudar ya que haciendo esto terminaria mi registro y seria una ayuda tremenda para llevar mis ventas con calidad y rapidez.

Desde ya muy agradecido.

Saludos cordiales.

Envio Email2.rar

Enlace a comentario
Compartir con otras webs

Archivado

Este tema está ahora archivado y está cerrado a más respuestas.

×
×
  • Crear nuevo...

Información importante

Echa un vistazo a nuestra política de cookies para ayudarte a tener una mejor experiencia de navegación. Puedes ajustar aquí la configuración. Pulsa el botón Aceptar, si estás de acuerdo.