Enviar email con dos cuentas. (modificar macro)

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