[resolvido] Loop sem Do

Moderador: Avelino Sampaio

marcelo3092
Mensagens: 85
Registrado em: 23 Jun 2016, 14:21

[resolvido] Loop sem Do

Mensagempor marcelo3092 » 02 Abr 2018, 00:29

Boa noite pessoal estou tentando adaptar um código de envio de email em massa para varios emails porem esta falando que esta loop sem do ja tentei varias coisas mais nada esta ai o código.

Private Sub Comando16_Click()
Dim Rs As DAO.Recordset
Dim N As Double
Set Rs = CurrentDb.OpenRecordset("SELECT * FROM Lembrete_Calendario")
Do While Not Rs.EOF

Dim Mens As Object
Dim Config As Object
Set Mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")

Do While Not Rs.EOF

With Config

.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("[smtpserver]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("[smtpserverport]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = DLookup("[sendusing]", "Empresa")
If DLookup("[smtpauthenticate]", "Empresa") = 1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
End If

If DLookup("[smtpuessl]", "Empresa") = -1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
End If

.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = DLookup("[sendusername]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("[sendpassword]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = DLookup("[smtpconnectiontimeout]", "Empresa")


If DLookup("[smtpuessl]", "Empresa") = -1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
End If

.Fields.Update
End With

Set Mens = New CDO.message
With Mens
Set .Configuration = Config
.From = getUsuarioAtual()

.sender = DLookup("[Email]", "Empresa")

.Subject = "Lembrete de Agendamento de Horário"
.TextBody = "Este é um lembrete de horário para aula na escola abaixo. Aluno(A), " & Rs!Aluno & vbCrLf _
& vbCrLf _
& "Horário: " & Rs!HoraCompromisso & vbCrLf _
& "Data: " & StrConv(Format(Rs!DataCompromisso, "dddd - dd-mmmm-yyyy"), vbProperCase) & vbCrLf _
& vbCrLf _
& "Empresa: " & DLookup("[Razão_Social]", "Empresa") & vbCrLf _
& "Telefone: " & DLookup("[Telefone]", "Empresa") & vbCrLf _
& "Endereço: " & DLookup("[Endereço]", "Empresa") & vbCrLf _
& "Cidade: " & DLookup("[Cidade]", "Empresa") & vbCrLf _
& "Enviado: " & Me.txtUsuarioAtual & vbCrLf _
& vbCrLf _
& DLookup("[Site]", "Empresa") & vbCrLf _


.To = "" & Rs!Email & ""
' a linha abaixo pega o pdf criado e anexa à mensagem


.Send


Set Mens = Nothing
Set Config = Nothing



Rs.MoveNext

End With

Loop



'DoCmd.OpenForm "frmFinalizar"

erromail:
If Err.Number = 13 Then
Resume Next
ElseIf Err.Number = -2147220979 Then
DoCmd.Close acForm, "Frm_Chamado_Enviado"
MsgBox "Você inseriu um endereço de email inválido ou inexistente." & vbCrLf & "Verifique o email e tente novamente.", vbOKOnly + vbCritical, "Email inválido"
'DoCmd.Close acForm, "frmFinalizar"

Else

End If


End Sub


se alguem pude me ajudar.

Disable adblock

Precisamos do seu apoio. Faca uma doacao para o site atraves do Paypal.


Avatar do usuário
Damasceno Jr.
Mensagens: 364
Registrado em: 08 Jun 2015, 01:30
Localização: Medicilândia-Pará

Re: Loop sem Do

Mensagempor Damasceno Jr. » 02 Abr 2018, 10:47

Vejo dois inícios de loop mas só um final:

Private Sub Comando16_Click()
Dim Rs As DAO.Recordset
Dim N As Double
Set Rs = CurrentDb.OpenRecordset("SELECT * FROM Lembrete_Calendario")
Do While Not Rs.EOF

Dim Mens As Object
Dim Config As Object
Set Mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")

Do While Not Rs.EOF

With Config

.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("[smtpserver]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("[smtpserverport]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = DLookup("[sendusing]", "Empresa")
If DLookup("[smtpauthenticate]", "Empresa") = 1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
End If

If DLookup("[smtpuessl]", "Empresa") = -1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
End If

.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = DLookup("[sendusername]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("[sendpassword]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = DLookup("[smtpconnectiontimeout]", "Empresa")


If DLookup("[smtpuessl]", "Empresa") = -1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
End If

.Fields.Update
End With

Set Mens = New CDO.message
With Mens
Set .Configuration = Config
.From = getUsuarioAtual()

.sender = DLookup("[Email]", "Empresa")

.Subject = "Lembrete de Agendamento de Horário"
.TextBody = "Este é um lembrete de horário para aula na escola abaixo. Aluno(A), " & Rs!Aluno & vbCrLf _
& vbCrLf _
& "Horário: " & Rs!HoraCompromisso & vbCrLf _
& "Data: " & StrConv(Format(Rs!DataCompromisso, "dddd - dd-mmmm-yyyy"), vbProperCase) & vbCrLf _
& vbCrLf _
& "Empresa: " & DLookup("[Razão_Social]", "Empresa") & vbCrLf _
& "Telefone: " & DLookup("[Telefone]", "Empresa") & vbCrLf _
& "Endereço: " & DLookup("[Endereço]", "Empresa") & vbCrLf _
& "Cidade: " & DLookup("[Cidade]", "Empresa") & vbCrLf _
& "Enviado: " & Me.txtUsuarioAtual & vbCrLf _
& vbCrLf _
& DLookup("[Site]", "Empresa") & vbCrLf _


.To = "" & Rs!Email & ""
' a linha abaixo pega o pdf criado e anexa à mensagem


.Send


Set Mens = Nothing
Set Config = Nothing



Rs.MoveNext

End With

Loop



'DoCmd.OpenForm "frmFinalizar"

erromail:
If Err.Number = 13 Then
Resume Next
ElseIf Err.Number = -2147220979 Then
DoCmd.Close acForm, "Frm_Chamado_Enviado"
MsgBox "Você inseriu um endereço de email inválido ou inexistente." & vbCrLf & "Verifique o email e tente novamente.", vbOKOnly + vbCritical, "Email inválido"
'DoCmd.Close acForm, "frmFinalizar"

Else

End If


End Sub
Quanto mais o tempo passa, mais descubro e mais me apaixono por MS Access.

marcelo3092
Mensagens: 85
Registrado em: 23 Jun 2016, 14:21

Re: Loop sem Do

Mensagempor marcelo3092 » 05 Abr 2018, 00:19

O Amigo Damasceno parece que resolvi depois de tenta bastante.
ficando assim.

Public Function fncemail()



Dim rs As DAO.Recordset
Set rs = RecordsetClone
Do While Not rs.EOF


Dim Mens As Object
Dim Config As Object
Set Mens = CreateObject("CDO.Message")
Set Config = CreateObject("CDO.Configuration")

With Config

.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserver") = DLookup("[smtpserver]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = DLookup("[smtpserverport]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendusing") = DLookup("[sendusing]", "Empresa")
If DLookup("[smtpauthenticate]", "Empresa") = 1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
End If

If DLookup("[smtpuessl]", "Empresa") = -1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
End If

.Fields("http://schemas.microsoft.com/cdo/configuration/sendusername") = DLookup("[sendusername]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/sendpassword") = DLookup("[sendpassword]", "Empresa")
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = DLookup("[smtpconnectiontimeout]", "Empresa")


If DLookup("[smtpuessl]", "Empresa") = -1 Then
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
Else
.Fields("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = False
End If

.Fields.Update
End With

Set Mens = New CDO.message
With Mens
Set .Configuration = Config
.From = getUsuarioAtual()

.sender = DLookup("[Email]", "Empresa")

.Subject = "Lembrete de Agendamento de Horário"
.TextBody = "Este é um lembrete de horário para aula na escola abaixo. Aluno(A), " & rs!Aluno & vbCrLf _
& vbCrLf _
& "Horário: " & rs!HoraCompromisso & vbCrLf _
& "Data: " & StrConv(Format(rs!DataCompromisso, "dddd - dd-mmmm-yyyy"), vbProperCase) & vbCrLf _
& vbCrLf _
& "Empresa: " & DLookup("[Razão_Social]", "Empresa") & vbCrLf _
& "Telefone: " & DLookup("[Telefone]", "Empresa") & vbCrLf _
& "Endereço: " & DLookup("[Endereço]", "Empresa") & vbCrLf _
& "Cidade: " & DLookup("[Cidade]", "Empresa") & vbCrLf _
& "Enviado: " & Me.txtUsuarioAtual & vbCrLf _
& vbCrLf _
& DLookup("[Site]", "Empresa") & vbCrLf _




.To = "" & rs!Email & ""



.Send

Set Mens = Nothing
Set Config = Nothing

rs.MoveNext

End With

Loop


DoCmd.OpenForm "frmFinalizar"

erromail:
If Err.Number = 13 Then
Resume Next
ElseIf Err.Number = -2147220979 Then
DoCmd.Close acForm, "frmProgresso"
MsgBox "Você inseriu um endereço de email inválido ou inexistente." & vbCrLf & "Verifique o email e tente novamente.", vbOKOnly + vbCritical, "Email inválido"
DoCmd.Close acForm, "frmFinalizar"

Else

End If

End Function

Disable adblock

Precisamos do seu apoio. Faca uma doacao para o site atraves do Paypal.



Voltar para “Módulos VBA”

Quem está online

Usuários neste fórum: Nenhum usuário registrado e 3 visitantes