enviar un correo desde una macro

[AlejandroChaires]

Public Sub EnviarCorreoConAnexo()
Application.ScreenUpdating = False


Dim myOlapp As Object
Dim myItem As Object
Dim myAttach As Object
Dim wbTmp As Workbook
Dim strRuta As String
Dim X
Dim pagina As Variant
Dim valor, valor2, partnom


Const olMailiTem As Integer = 0
Const olByValue As Integer = 1

Set myOlapp = CreateObject("Outlook.Application")
Set myItem = myOlapp.CreateItem(olMailiTem)
Set myAttach = myItem.Attachments
'HOJA DONDE TIENES TUS CONTACTOS
Sheets("Email_Account").Activate

'AQUI PONES LA CELDADONDE EMPEARAN TUS CORREOS SE CREA UNA VARIABLE
Range("B2").Select

Do While ActiveCell.Value <> Empty
correo = correo & ActiveCell.Value & ";"
ActiveCell.Offset(1, 0).Select
'Range("B" & 1 + X).Select
X = X + 1

Loop


Sheets(pagina).Activate

Loop

.LA RUTA EN DONDE LO GUARDARAS PARA PONERLO COMO ATTACH
strRuta = "P:\LoG_Held\pagina.xls"

Sheets(pagina).Activate
ActiveSheet.Copy
ActiveWorkbook.SaveAs strRuta
Columns("A:L").Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Range("A1").Select
Application.CutCopyMode = False


myAttach.Add strRuta, olByValue, 1, "Bloqueo"
myItem.Subject ="nombre pagina"
myItem.body = "Cuerpo del mensaje"
myItem.to = correo
myItem.display

'Kill strRuta

Set myOlapp = Nothing
Set myItem = Nothing
Set myAttach = Nothing

End Sub

ESPERO Y TE SIRVA
MC