Tengo el siguiente código con el cual pretendo enviar por correo dos hojas ("Parts Service", "Fault ") de este mismo libro, pero antes de enviar esas hojas quiero que me las guarde en una ruta , la cual ya solucione, ya que genere una lista de los archivos adjuntos que se enviaran, pero me sigue saliendo el error 440 "Se produjo el siguiente error: No se pueden agregar los datos adjuntos. Falta el origen de los datos", pero lo chistoso es que se enviar el correo con los archivos adjuntos
Requiero de su apoyo en dos cosas, optimizar el codigo si se puede, si no pues solo la solucion del error
De antemano agradezco su apoyo con mi codigo..... saludos
Sub Email_Solic_SR_RMA()
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim strTitulo As String
Dim Continuar As String
Dim OA, OM As Object
Dim NA As Variant
Dim Ruta, fname, mydoc, Sitio As String
Dim i, j As Integer
Dim pagina2 As Worksheet
Set pagina2 = ActiveWorkbook.Worksheets("Captura_HW")
Ruta = Range("C3") & "\" & "HW" & "\"
TD = Format(Range("B5").Value, "YYYY-mm-dd") & "-" & Sheets("Captura_HW").Range("C2") & "_" & "Parts Service"
mydoc = Ruta & TD & ".xlsx"
Range("j13") = mydoc
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
Sheets("Parts Service").Visible = True
Sheets("Fault").Visible = True
Sheets(Array("Parts Service", "Fault")).Copy
For Each ws In ActiveWorkbook.Worksheets
With ws.UsedRange
.Value = .Value
End With
Next ws
With ActiveWorkbook
.SaveAs Filename:=mydoc, FileFormat:=xlWorkbookDefault, CreateBackup:=False
.Close False
End With
Sheets("Parts Service").Visible = True
Sheets("Fault").Visible = True
'Contar el numero de archivos adjuntos
Dim numeroArchivos As Integer
numeroArchivos = 0
Do While pagina2.Cells(12 + numeroArchivos, 10) <> ""
numeroArchivos = numeroArchivos + 1
Loop
strTitulo = "CONTROL DE REPARACIONES "
Continuar = MsgBox("Desea enviar el correo a:?" & vbCrLf & Range("F14").Value & vbCrLf & Range("F15").Value, vbYesNo + vbExclamation, strTitulo)
If Continuar = vbNo Then Exit Sub
Set OA = CreateObject("Outlook.Application")
Set OM = OA.CREATEITEM(0)
With OM
.To = Range("F14").Value
.CC = Range("F15").Value
.Subject = Range("C16").Value
.Body = Range("C18").Value
.Attachments.Add numeroArchivos
For i = 1 To numeroArchivos
.Attachments.Add (pagina2.Cells(12 + i, 10).Value)
Next i
.Send
End With
If Err.Number = 0 Then
SendMail_Gmail = True
MsgBox "El mail con archivo adjunto fue enviado con éxito", vbInformation, "« A V I S O »"
Else
MsgBox "Se produjo el siguiente error: " & Err.Description, vbCritical, "Error numero: " & Err.Number
End If
Kill mydoc
Set OM = Nothing
Set OA = Nothing
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Sheets("Parts Service").Visible = False
Sheets("Fault").Visible = False
'LIMPIAR LAS CELDAS
If MsgBox("¿Desea limpiar los valores de los campos?", vbYesNo) = vbYes Then
Range("F14:I14").ClearContents
Range("I15").ClearContents
Range("J13:J18").ClearContents
Range("L13") = " "
Call ElimnarFotosFilas
End If
End Sub
Featured Replies
Archivado
Este tema está ahora archivado y está cerrado a más respuestas.
buen Dia masters
Tengo el siguiente código con el cual pretendo enviar por correo dos hojas ("Parts Service", "Fault ") de este mismo libro, pero antes de enviar esas hojas quiero que me las guarde en una ruta , la cual ya solucione, ya que genere una lista de los archivos adjuntos que se enviaran, pero me sigue saliendo el error 440 "Se produjo el siguiente error: No se pueden agregar los datos adjuntos. Falta el origen de los datos", pero lo chistoso es que se enviar el correo con los archivos adjuntos
Requiero de su apoyo en dos cosas, optimizar el codigo si se puede, si no pues solo la solucion del error
De antemano agradezco su apoyo con mi codigo..... saludos
Sub Email_Solic_SR_RMA() Application.ScreenUpdating = False Application.DisplayAlerts = False Dim strTitulo As String Dim Continuar As String Dim OA, OM As Object Dim NA As Variant Dim Ruta, fname, mydoc, Sitio As String Dim i, j As Integer Dim pagina2 As Worksheet Set pagina2 = ActiveWorkbook.Worksheets("Captura_HW") Ruta = Range("C3") & "\" & "HW" & "\" TD = Format(Range("B5").Value, "YYYY-mm-dd") & "-" & Sheets("Captura_HW").Range("C2") & "_" & "Parts Service" mydoc = Ruta & TD & ".xlsx" Range("j13") = mydoc Application.ScreenUpdating = False Application.EnableEvents = False On Error Resume Next Sheets("Parts Service").Visible = True Sheets("Fault").Visible = True Sheets(Array("Parts Service", "Fault")).Copy For Each ws In ActiveWorkbook.Worksheets With ws.UsedRange .Value = .Value End With Next ws With ActiveWorkbook .SaveAs Filename:=mydoc, FileFormat:=xlWorkbookDefault, CreateBackup:=False .Close False End With Sheets("Parts Service").Visible = True Sheets("Fault").Visible = True 'Contar el numero de archivos adjuntos Dim numeroArchivos As Integer numeroArchivos = 0 Do While pagina2.Cells(12 + numeroArchivos, 10) <> "" numeroArchivos = numeroArchivos + 1 Loop strTitulo = "CONTROL DE REPARACIONES " Continuar = MsgBox("Desea enviar el correo a:?" & vbCrLf & Range("F14").Value & vbCrLf & Range("F15").Value, vbYesNo + vbExclamation, strTitulo) If Continuar = vbNo Then Exit Sub Set OA = CreateObject("Outlook.Application") Set OM = OA.CREATEITEM(0) With OM .To = Range("F14").Value .CC = Range("F15").Value .Subject = Range("C16").Value .Body = Range("C18").Value .Attachments.Add numeroArchivos For i = 1 To numeroArchivos .Attachments.Add (pagina2.Cells(12 + i, 10).Value) Next i .Send End With If Err.Number = 0 Then SendMail_Gmail = True MsgBox "El mail con archivo adjunto fue enviado con éxito", vbInformation, "« A V I S O »" Else MsgBox "Se produjo el siguiente error: " & Err.Description, vbCritical, "Error numero: " & Err.Number End If Kill mydoc Set OM = Nothing Set OA = Nothing Application.ScreenUpdating = True Application.DisplayAlerts = True Sheets("Parts Service").Visible = False Sheets("Fault").Visible = False 'LIMPIAR LAS CELDAS If MsgBox("¿Desea limpiar los valores de los campos?", vbYesNo) = vbYes Then Range("F14:I14").ClearContents Range("I15").ClearContents Range("J13:J18").ClearContents Range("L13") = " " Call ElimnarFotosFilas End If End Sub