Sub envio_mail2()
'Tambien adjunta archivos
'No necesita abrir el Outlook para hacer la macro

Application.ScreenUpdating = False
'On Error GoTo ende

Dim objOutlook As Object
Dim mItem As Object
Dim ruta_archivo As String

  Range("A5").Select
  Range(Selection, Selection.End(xlDown)).Select
  nume_regi = Selection.Count

ruta_archivo = Cells(13, 5).Value
  
  
For i = 1 To nume_regi
' Set OutlookOBJ = CreateObject("Outlook.Application")
' Set mItem = OutlookOBJ.CreateItem(olMailItem)
    
 Enviara = Cells(4 + i, 3)
 asunto = Cells(2, 5)
 Cuerpo = Cells(5, 5)
 empresa = Cells(4 + i, 2)
 persona = Cells(4 + i, 1)

 With mItem
    .To = Enviara
    .Subject = asunto & " para " & empresa
    .Body = "Hola " & persona & vbCrLf & vbCrLf & Cuerpo & vbCrLf & vbCrLf & "Saludos Cordiales"
    '.Send
 End With
 
 If ruta_archivo <> "" Then
    With mItem
    .Attachments.Add (ruta_archivo)
    End With
 End If
 
    With mItem
    .Send
    End With
 
 
Next i

Range("A5").Select

Application.ScreenUpdating = True
Set OutlookOBJ = Nothing
Set mItem = Nothing

MsgBox ("Finalizado se enviaron " & nume_regi & " Correos con exito")
Exit Sub

ende:
MsgBox "no se mandaron los correos verificar informacion"

End Sub

Private Sub Text1_Change()

On Error Resume Next
    Dim cBuscar As String
    If Text1.Text = "" Then Exit Sub
    cBuscar = "Tarjeta LIKE '%" & Text1.Text & "%'"
    rs.MoveFirst
    rs.Find (cBuscar)
'    End If

End Sub

Private Sub Filtrar_click()
 
    Dim sFiltro As String
    
    If Text1.Text <> 0 Then
       sFiltro = "tarjeta LIKE '%" & Text1.Text & "%'"
    If Len(Trim(sFiltro)) = 0 Then
        cnn.Filter = adFilterNone
    Else
        cnn.Filter = sFiltro
    End If
    cnn.Requery
    Set MSHFlexGrid.Recordset = cnn
    
End Sub