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

 

Editado el el 20 de julio2 años por Miguel A. Tamaniz H.

Podría venir por el número de archivo prueba:

        For i = 0 To numeroArchivos - 1 '<-----------------
        .Attachments.Add (pagina2.Cells(12 + i, 10).Value)
        Next i

 

buenas tardes master, hice la modificacion que muy amable me recomendo, pero ahora me salio el siguiente numero de error

error numero: -2147024894

"Se produjo el siguiente error: No se encuentra el archivo. Compruebe que la ruta de acceso y el nombre sean correctos."

Si el resultado con tu macro inicial es correcto, prueba añadiendo al principio de la macro:

 On Error Resume Next 

Si no se soluciona, sube el archivo a ver si probando la macro vemos algo.

Editado el el 21 de julio2 años por Antoni

En 21/7/2023 at 2:50 , Antoni dijo:

Si el resultado con tu macro inicial es correcto, prueba añadiendo al principio de la macro:

 On Error Resume Next 

Si no se soluciona, sube el archivo a ver si probando la macro vemos algo.

Buenas tardes @Antoni si  tengo esa linea  en el codigo

Cita

Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next