Código deixando lento a aplicação no access

Olá pessoal!
Preciso de uma ajuda para identificar o porque que o código abaixo está deixando minha aplicação lenta.
Esse código é acionado quando clico no botao, mas depois de executado umas 3 ou 4 vezes ele chega a travar o access sendo liberado somente quando deletado pelo gerenciador de tarefas.

Se conseguirem identificar o que causa essa lentidão e travamento, agradeço.

Option Compare Database
Option Explicit

Public Function SendMailHE()
Dim rs As DAO.Recordset
Dim txtnome As String
Dim txtHEntrada As String
Dim txtContEntrada As String
Dim txtContSaida As String
Dim txtEmail_Pai As String
Dim txtEmail_Mae As String
Dim txtData As String

Set rs = CurrentDb.OpenRecordset("SELECT * FROM Con_HE_SendEmail_Pais where Con_HE_SendEmail_Pais.[registro]= " & [Forms]![Aluno1]![Registro] & "")

txtnome = StrConv(rs!Nome, vbProperCase)
txtHEntrada = Format(rs!HEntrada, "hh:mm")
txtContEntrada = Format(rs!horacontr_entrada, "hh:mm")
txtContSaida = Format(rs!horacontr_saida, "hh:mm")
txtEmail_Pai = Nz(rs!Email_Pai, Nz(rs!email_Mae, "sem email"))
txtEmail_Mae = Nz(rs!email_Mae, Nz(rs!Email_Pai, "sem email"))
txtData = rs!Data

If (txtHEntrada) <> "" Then

Dim Obj As Object

Set Obj = CreateObject("CDO.Message")
With Obj.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "email-ssl.com.br"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "email FROM"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "senha"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 30
.Update
End With

With Obj
.To = txtEmail_Pai & ";" & txtEmail_Mae
.BCC = "email oculto"
.FROM = "Notificação"
.Subject = "" & txtnome & " - Hora adicional gerada em " & txtData
.HTMLBody = "Prezados Pais!

Informamos que foi gerado " & txtHEntrada & " de hora adicional devido a entrada antecipada.

" & " Período contratado.
Entrada: " & txtContEntrada & "
Saída: " & txtContSaida & "

Em caso de dúvida, pedimos a gentileza de entrar em contato pelo WhatsApp " & "(11) xxxxxxxxx.""
Esta caixa de email não recebe mensagem.


A Direção"

End With

On Error Resume Next
Obj.Send

If Err.Number <> 0 Then
MsgBox "CDO Error " & vbNewLine & Err.Description, vbCritical, "Avíso"
Else
'MsgBox "Mensaje enviado con éxito", vbInformation, "Avíso"
End If
rs.Close
Set rs = Nothing
Set Obj = Nothing

End If
End Function