[Resolvido]Código de erro de Transporte foi 0x80040217

Bom dia amigos,

À meses atras criei um código para enviar email, sendo que o mesmo estava funcionando corretamente, fiz vários testes e o mesmo estava sem erro algum, porém fui emplementar o mesmo código só que em outro formulário e agora está dando erro 0x80040217 dizendo que a resposta do servidor foi not available.
O que pode ter acontecido neste intervalo entre estar funcionando e agora não está funcionando, última tela de email que teste foi em setembro de 2017.
Segue o código para verificação:

'On Error GoTo trato
   Forms!FRM_SOLCOMPRAS!Envioemail = "* Solicitação de Compras enviado em " & Date & " às " & Time & "." & vbCrLf & Forms!FRM_SOLCOMPRAS!Envioemail
Dim strArquivo, strLocal, strSolicitante, strPrioridade, strcadastro, strdata, strcademail As String
   strcadastro = Forms!FRM_SOLCOMPRAS!Cadastro
   strdata = Forms!FRM_SOLCOMPRAS!DataCadastro
   strArquivo = "Solicitação de Compras Nº 0" & strcadastro & ".pdf"
   strLocal = CurrentProject.Path & "\Temp\" & strArquivo
   strSolicitante = Forms!FRM_SOLCOMPRAS!solicitante
   strPrioridade = Forms!FRM_SOLCOMPRAS!prioridade
   strcademail = Forms!FRM_SOLCOMPRAS!cademail
   
   'Abre o relatório devidamente filtrado e oculto
DoCmd.OpenReport "REL_SOLCOMPRAS", acViewPreview, , "Cadastro=" & Forms!FRM_SOLCOMPRAS!Cadastro, acHidden
   'Gera arquivo pdf do relatório previamente aberto e filtrado.
DoCmd.OutputTo acOutputReport, "REL_SOLCOMPRAS", acFormatPDF, strLocal

   'Fecha o relatório
DoCmd.Close acReport, "REL_SOLCOMPRAS"
'até aqui´código salva na pasta especificada


   'Enviar email
   'Macro para enviar email, necessita habilitar referencia
   'Na janela VBA --> Ferramentas --> Referências --> Microsoft CDO for Windows
'On Error GoTo Trato

Dim vMensagem As String, vDestinatario As String, vTitulo As String
Dim lobj_cdomsg As CDO.Message
Dim vNetwork As Object
Dim Rsemail, Rssenha, Rsservidor, Rsportae, Rsportas, Rspadrao, Rspadrao1, Rspadrao2, Rspadrao3, Rspadrao4 As DAO.Recordset
Dim AddAttachment As Object

vDestinatario = [email]


Set vNetwork = CreateObject("WScript.Network")
Set Rsemail = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.cdoSendUserName, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rssenha = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.cdoSendPassword, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rsservidor = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.cdoSMTPServer, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rsportae = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.cdoSMTPConnectionTimeout, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rsportas = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.cdoSMTPServerPort, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rspadrao = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.Padrao, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rspadrao1 = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.Padrao1, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rspadrao2 = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.Padrao2, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rspadrao3 = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.Padrao3, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")
Set Rspadrao4 = CurrentDb.OpenRecordset("SELECT TBL_CONFIGEMAIL.Padrao4, TBL_CONFIGEMAIL.Cadastro FROM TBL_CONFIGEMAIL WHERE (((TBL_CONFIGEMAIL.Cadastro)=" & strcademail & " ))")

vLogado = vNetwork.UserName

   Set lobj_cdomsg = New CDO.Message
   With lobj_cdomsg.Configuration
       .Fields(cdoSendUserName) = "consultoria@bateriasvolt.com.br"                  'Rsemail("cdoSendUserName")                           'Aqui vai o endereço de e-mail que será responsável pelo envio
       .Fields(cdoSendPassword) = Rssenha("cdoSendPassword")                           'Aqui vai a senha do e-mail
       .Fields(cdoSMTPAuthenticate) = cdoBasic
       .Fields(cdoSMTPServer) = Rsservidor("cdoSMTPServer")                             'Nome do servidor SMTP
       .Fields(cdoSMTPConnectionTimeout) = Rsportae("cdoSMTPConnectionTimeout")        'Porta entrada
       .Fields(cdoSMTPServerPort) = Rsportas("cdoSMTPServerPort")                     'Porta saida
       .Fields(cdoSendUsingMethod) = cdoSendUsingPort
       .Fields.Update
       vMensagem = "Relatório de Solicitação de Compras" & Chr(13) & Chr(13) & Chr(13)   'chr siginifica nova linhaou linhas em branco
       vMensagem = vMensagem & "Solicitação Nº: " & [strcadastro] & "" & Chr(13) & Chr(13)
       'vMensagem = vMensagem & "Solicitante: " & [solicitante] & "" & Chr(13) & Chr(13)
       vMensagem = vMensagem & "Aberto por: " & vLogado & Chr(13) & Chr(13)
       vMensagem = vMensagem & "Data da Solicitação: " & [strdata] & "" & Chr(13) & Chr(13)
       vMensagem = vMensagem & "Solicitante: " & [strSolicitante] & "" & Chr(13) & Chr(13)
       vMensagem = vMensagem & "Prioridade: " & [strPrioridade] & "" & Chr(13) & Chr(13)
       vMensagem = vMensagem & "Nome do Arquivo: " & [strArquivo] & "" & Chr(13) & Chr(13) & Chr(13)
       vMensagem = vMensagem & Rspadrao("Padrao") & Chr(13)
       vMensagem = vMensagem & Rspadrao1("Padrao1") & Chr(13)
       vMensagem = vMensagem & Rspadrao2("Padrao2") & Chr(13)
       vMensagem = vMensagem & Rspadrao3("Padrao3") & Chr(13)
       vMensagem = vMensagem & Rspadrao4("Padrao4") & Chr(13)
   End With
   
   
   If Status = "Em Aberto" Then
       vTitulo = "Solicitação de Compras Sob o Nº - " & [strcadastro] & ""        'Assunto
   Else
       vTitulo = "Autorização de Compras Sob o Nº - " & [strcadastro] & ""         'Assunto
   End If
   With lobj_cdomsg
       .To = vDestinatario
       .FROM = Rsemail("cdoSendUserName")                     'Endereço remetente (o mesmo da conexão q vc fez )
       .Subject = vTitulo                                      'Assunto
       .TextBody = vMensagem
       .AddAttachment CurrentProject.Path & "\Temp\" & strArquivo
       .Send
   End With
   DoCmd.Close acForm, "FRM_EMAIL1"
   Exit Sub
trato:         MsgBox "Configurações e/ou email do Setor não cadastrado.", vbInformation, "SGQ"


Aguardo ajuda dos amigos.

Att,

Valdenir

boa tarde pessoal,

Tópico resolvido, na verdade só recadastrei novamente o email do remetente com a senha e as portas e o mesmo voltou a funcionar, acho que como copiei a tabela somente para teste de outro bd, alguma coisa saiu errado, e ao recadastrar voltou a funcionar.

Att,

valdenir

Olá Valdenir,

Obrigado pelo retorno, o fórum agradece.

Abraço