Ayuda Macro envío de Correo
Publicado por David T (22 intervenciones) el 08/08/2008 15:38:19
Buen día, espero me puedan ayudar ya que no encuentro la forma de solucionar mi problema, lo que hace la macro que les presento a continuación es enviar un correo desde excel por medio de Lotus Notes, el detalle es que viene un For - Next y lo aplica para todas las Sheets que vengan en el archivo, lo que quiero es eliminar el For - Next y que únicamente se aplique en la Sheet activa, ya intente varias formas pero debido a mi bajo conocimiento no lo he podido lograr,
Espero alguien me pueda apoyar a solucionar mi problema..
Muchas Gracias....
Sub Enviar_Correo()
Const EMBED_ATTACHMENT As Long = 1454
Const stPath As String = "C:Documents and Settings"
Dim stSubject As String
stSubject = "Prueba"
Dim vaMsg As Variant
mensaje = "prueba"
vaMsg = "Buen Día !"
Dim vaRecipients As Variant
Dim stFileName As String
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
On Error GoTo Error_Handling
Application.ScreenUpdating = False
Set wbBook = ActiveWorkbook
'*************************************************
For Each wsSheet In wbBook.Worksheets
With wsSheet
.Copy
stFileName = .Name
End With
stAttachment = stPath & "" & stFileName & ".xls"
With ActiveWorkbook
.SaveAs stAttachment
.Close
End With
'vaRecipients = .Range("A2:A" & lnLastRow).Value
vaRecipients = InputBox("Destinatario")
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
.Subject = stSubject
.Body = vaMsg
.SaveMessageOnSend = False
.PostedDate = Now()
.Send 0, vaRecipients
End With
Kill stAttachment
Next wsSheet
*****************************************************
MsgBox ("El e-mail se ha Enviado Exitosamente."), vbInformation
ExitSub:
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
Exit Sub
Error_Handling:
MsgBox "Error Número: " & Err.Number & vbNewLine & _
"Descripcion: " & Err.Description, vbOKOnly
Kill stAttachment
Resume ExitSub
Application.ScreenUpdating = True
End Sub
Saludos....
Espero alguien me pueda apoyar a solucionar mi problema..
Muchas Gracias....
Sub Enviar_Correo()
Const EMBED_ATTACHMENT As Long = 1454
Const stPath As String = "C:Documents and Settings"
Dim stSubject As String
stSubject = "Prueba"
Dim vaMsg As Variant
mensaje = "prueba"
vaMsg = "Buen Día !"
Dim vaRecipients As Variant
Dim stFileName As String
Dim noSession As Object
Dim noDatabase As Object
Dim noDocument As Object
Dim noEmbedObject As Object
Dim noAttachment As Object
Dim stAttachment As String
Dim wbBook As Workbook
Dim wsSheet As Worksheet
On Error GoTo Error_Handling
Application.ScreenUpdating = False
Set wbBook = ActiveWorkbook
'*************************************************
For Each wsSheet In wbBook.Worksheets
With wsSheet
.Copy
stFileName = .Name
End With
stAttachment = stPath & "" & stFileName & ".xls"
With ActiveWorkbook
.SaveAs stAttachment
.Close
End With
'vaRecipients = .Range("A2:A" & lnLastRow).Value
vaRecipients = InputBox("Destinatario")
Set noSession = CreateObject("Notes.NotesSession")
Set noDatabase = noSession.GETDATABASE("", "")
If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
Set noDocument = noDatabase.CreateDocument
Set noAttachment = noDocument.CreateRichTextItem("stAttachment")
Set noEmbedObject = noAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
With noDocument
.Form = "Memo"
.SendTo = vaRecipients
.Subject = stSubject
.Body = vaMsg
.SaveMessageOnSend = False
.PostedDate = Now()
.Send 0, vaRecipients
End With
Kill stAttachment
Next wsSheet
*****************************************************
MsgBox ("El e-mail se ha Enviado Exitosamente."), vbInformation
ExitSub:
Set noEmbedObject = Nothing
Set noAttachment = Nothing
Set noDocument = Nothing
Set noDatabase = Nothing
Set noSession = Nothing
Exit Sub
Error_Handling:
MsgBox "Error Número: " & Err.Number & vbNewLine & _
"Descripcion: " & Err.Description, vbOKOnly
Kill stAttachment
Resume ExitSub
Application.ScreenUpdating = True
End Sub
Saludos....
Valora esta pregunta


0