- 02 Mai 2015 às 12:41
#602
Senhores
Boa Tarde
Ao tentar executar a Macro abaixo a partir do botão 'ENVIAR", nada acontece
ou seja os e-mail's não são gerados e nem emitidos, pois a tela fica 'PARADA'.
Me parece-que a macro não é startada, pois os totais finais não são exbidos.
Um detalhe: o outlook emite constatemente a seguinte mensagem:
O servidor IMAP encerrou sua conexão
Protocolo: IMAP
Servidor: imap.uol.com.br
Porta: 993
Código erro: ox800CCCDD
A Macro é a seguinte:
Sub EnviarEmail()
'Escrito por Laennder (gurudoexcel.com/forum)
Dim sTO As String 'Destinatario
Dim sCC As String 'Destinatário Cópia
Dim sMEs As String 'Mês
Dim sNome As String 'Nome do Cliente
Dim dValor As Double 'Valor Devido
Dim i As Integer 'Contador
Dim Total As Integer
Dim Qty As Integer
Dim sht As Worksheet
'Defina a planilha onde estão os dados
Set sht = Plan4
sMEs = InputBox("Digite o mes referente as refeições: exemplo 'Abril/2015' ", _
"Mês referente", UCase(Format(Date - 1, "MMMM") & "/" & Format(Date - 1, "YYYY")))
Qty = WorksheetFunction.CountA(Plan1.Columns(1))
For i = 2 To Qty
sNome = sht.Cells(i, 1) 'Coluna 1 (A)
dValor = sht.Cells(i, 27) 'Coluna 27 (AA)
sTO = sht.Cells(i, 2) 'Coluna 2 (B)
sCC = "c.tavares@uol.com.br"
If sTO <> "" And dValor > 0 Then
'Enviar email
Dim oOutlookApp As Object
Dim oOutlookMessage As Object
Dim ns As Outlook.Namespace
Dim Folder As Outlook.MAPIFolder
'Instacia os objetos
Set oOutlookApp = New Outlook.Application
Set oOutlookMessage = oOutlookApp.CreateItem(olMailItem)
Set ns = oOutlookApp.GetNamespace("MAPI")
Set oOutlookApp = ns.GetDefaultFolder(olFolderInbox)
oOutlookMessage.HTMLBody = "<p>Prezado(a) " & sNome & ", </p>" _
& "<p>O valor total das suas refeições em " & sMEs & " foi de R$: " & Format(dValor, "#,##0.00") & "</p>" _
& "Atenciosamente, "
With oOutlookMessage
.Subject = "Valor de Suas Refeições"
.to = sTO
.CC = sCC
'.Display
.Send
End With
oOutlookApp.Quit
Set oOutlookApp = Nothing
'fim do envio do email
'Aumenta o contador
Total = Total + 1
End If
Next i
MsgBox "Processo finalizado" & Chr(13) & "Total de emails enviados: " & Total, vbInformation, "AVISO"
End Sub
Public Sub formulario_email()
UserForm1.Show
End Sub
Desde já agradeço
Att.
Claudio Tavares
Boa Tarde
Ao tentar executar a Macro abaixo a partir do botão 'ENVIAR", nada acontece
ou seja os e-mail's não são gerados e nem emitidos, pois a tela fica 'PARADA'.
Me parece-que a macro não é startada, pois os totais finais não são exbidos.
Um detalhe: o outlook emite constatemente a seguinte mensagem:
O servidor IMAP encerrou sua conexão
Protocolo: IMAP
Servidor: imap.uol.com.br
Porta: 993
Código erro: ox800CCCDD
A Macro é a seguinte:
Sub EnviarEmail()
'Escrito por Laennder (gurudoexcel.com/forum)
Dim sTO As String 'Destinatario
Dim sCC As String 'Destinatário Cópia
Dim sMEs As String 'Mês
Dim sNome As String 'Nome do Cliente
Dim dValor As Double 'Valor Devido
Dim i As Integer 'Contador
Dim Total As Integer
Dim Qty As Integer
Dim sht As Worksheet
'Defina a planilha onde estão os dados
Set sht = Plan4
sMEs = InputBox("Digite o mes referente as refeições: exemplo 'Abril/2015' ", _
"Mês referente", UCase(Format(Date - 1, "MMMM") & "/" & Format(Date - 1, "YYYY")))
Qty = WorksheetFunction.CountA(Plan1.Columns(1))
For i = 2 To Qty
sNome = sht.Cells(i, 1) 'Coluna 1 (A)
dValor = sht.Cells(i, 27) 'Coluna 27 (AA)
sTO = sht.Cells(i, 2) 'Coluna 2 (B)
sCC = "c.tavares@uol.com.br"
If sTO <> "" And dValor > 0 Then
'Enviar email
Dim oOutlookApp As Object
Dim oOutlookMessage As Object
Dim ns As Outlook.Namespace
Dim Folder As Outlook.MAPIFolder
'Instacia os objetos
Set oOutlookApp = New Outlook.Application
Set oOutlookMessage = oOutlookApp.CreateItem(olMailItem)
Set ns = oOutlookApp.GetNamespace("MAPI")
Set oOutlookApp = ns.GetDefaultFolder(olFolderInbox)
oOutlookMessage.HTMLBody = "<p>Prezado(a) " & sNome & ", </p>" _
& "<p>O valor total das suas refeições em " & sMEs & " foi de R$: " & Format(dValor, "#,##0.00") & "</p>" _
& "Atenciosamente, "
With oOutlookMessage
.Subject = "Valor de Suas Refeições"
.to = sTO
.CC = sCC
'.Display
.Send
End With
oOutlookApp.Quit
Set oOutlookApp = Nothing
'fim do envio do email
'Aumenta o contador
Total = Total + 1
End If
Next i
MsgBox "Processo finalizado" & Chr(13) & "Total de emails enviados: " & Total, vbInformation, "AVISO"
End Sub
Public Sub formulario_email()
UserForm1.Show
End Sub
Desde já agradeço
Att.
Claudio Tavares