Tenho este script que funciona bem. a Bastante tempo.
Foi contribuição aqui do fórum.
- Existe como eu enviar (Exemplo)
RP01", "RP01 para destinatario de email x@x.com.br
RP02", "RP02 para destinatario de email y@y.com.br
no macro abaixo:
Alguém tem alguma dica?
Hoje é enviado para todos ao mesmo tempo. E seria melhor enviar relatório individual
*********************************************************************************************************
sub PrintReport
Set WSHShell = CreateObject("WScript.Shell")
fln = "C:\tmp\myreport.pdf"
RegKey = "HKEY_CURRENT_USER\Software\QlikViewPDF\"
WSHShell.RegWrite RegKey & "BypassSaveAs", 1
WSHShell.RegWrite RegKey & "OutputFile", fln
ActiveDocument.GetApplication.Sleep 2000
WSHShell.RegWrite RegKey & "BypassSaveAs", 0
WSHShell.RegWrite RegKey & "OutputFile", ""
Set WSHShell = nothing
end sub
function GetVariable(varName)
Dim v
set v = ActiveDocument.Variables(varName)
GetVariable = v.GetContent.String
end function
Sub ExecMacro()
ActiveDocument.Reload
Envio()
ActiveDocument.Save
ActiveDocument.GetApplication.Quit
ActiveDocument.GetApplication.Close
End Sub
Sub Envio()
'Set TabelaEmails = ActiveDocument.Fields("Gerente").GetPossibleValues(1000)
'For contEmail = 0 to TabelaEmails.Count - 1 ' Aqui faz um Laco com o campo "Gerente"......
'ActiveDocument.Fields("Gerente").Select TabelaEmails.Item(contEmail).Text
'===========================================================================================
'Aqui apaga se tiver os arquivos.....
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\Relatorio1.pdf") then
filesys.DeleteFile "C:\tmp\Relatorio1.pdf"
End If
Set filesys = Nothing
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\Relatorio2.pdf") then
filesys.DeleteFile "C:\tmp\Relatorio2.pdf"
End If
Set filesys = Nothing
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\Geral.pdf") then
filesys.DeleteFile "C:\tmp\Geral.pdf"
End If
Set filesys = Nothing
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\Tiradentes-82.pdf") then
filesys.DeleteFile "C:\tmp\Tiradentes-82.pdf"
End If
Set filesys = Nothing
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\Brasil-282.pdf") then
filesys.DeleteFile "C:\tmp\Brasil-282.pdf"
End If
Set filesys = Nothing
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\Ramalho-182.pdf") then
filesys.DeleteFile "C:\tmp\Ramalho-182.pdf"
End If
'===========================================================================================
' Aqui roda o relatorio ID RP01
ActiveDocument.GetApplication.Sleep 2000
Set filesys = Nothing
ActiveDocument.PrintDocReport "RP01", "RP01"
PrintReport()
ActiveDocument.GetApplication.Sleep 3000
' Aqui se existe o PDF, entao renomeia ele.......
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\QlikView Printing.pdf") then
filesys.MoveFile "C:\tmp\QlikView Printing.pdf", "C:\tmp\Relatorio1.pdf"
End If
Set filesys = Nothing
ActiveDocument.GetApplication.Sleep 3000
'===========================================================================================
' Aqui roda o relatorio ID RP02
ActiveDocument.PrintDocReport "RP02", "RP02"
PrintReport()
ActiveDocument.GetApplication.Sleep 3000
' Aqui se existe o PDF, entao renomeia ele.......
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\QlikView Printing.pdf") then
filesys.MoveFile "C:\tmp\QlikView Printing.pdf", "C:\tmp\Relatorio2.pdf"
End If
Set filesys = Nothing
ActiveDocument.GetApplication.Sleep 3000
'===========================================================================================
' Aqui roda o relatorio ID RP03
ActiveDocument.PrintDocReport "RP03", "RP03"
PrintReport()
ActiveDocument.GetApplication.Sleep 3000
' Aqui se existe o PDF, entao renomeia ele.......
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\QlikView Printing.pdf") then
filesys.MoveFile "C:\tmp\QlikView Printing.pdf", "C:\tmp\Geral.pdf"
End If
Set filesys = Nothing
ActiveDocument.GetApplication.Sleep 3000
' '===========================================================================================
' Aqui roda o relatorio ID RP04
ActiveDocument.PrintDocReport "RP04", "RP04"
PrintReport()
ActiveDocument.GetApplication.Sleep 3000
' Aqui se existe o PDF, entao renomeia ele.......
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\QlikView Printing.pdf") then
filesys.MoveFile "C:\tmp\QlikView Printing.pdf", "C:\tmp\Tiradentes-82.pdf"
End If
Set filesys = Nothing
ActiveDocument.GetApplication.Sleep 3000
' '===========================================================================================
' Aqui roda o relatorio ID RP04
ActiveDocument.PrintDocReport "RP05", "RP05"
PrintReport()
ActiveDocument.GetApplication.Sleep 3000
' Aqui se existe o PDF, entao renomeia ele.......
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\QlikView Printing.pdf") then
filesys.MoveFile "C:\tmp\QlikView Printing.pdf", "C:\tmp\Brasil-282.pdf"
End If
Set filesys = Nothing
ActiveDocument.GetApplication.Sleep 3000
'===========================================================================================
' Aqui roda o relatorio ID RP04
ActiveDocument.PrintDocReport "RP06", "RP06"
PrintReport()
ActiveDocument.GetApplication.Sleep 3000
' Aqui se existe o PDF, entao renomeia ele.......
Set filesys = CreateObject("Scripting.FileSystemObject")
If filesys.FileExists("C:\tmp\QlikView Printing.pdf") then
filesys.MoveFile "C:\tmp\QlikView Printing.pdf", "C:\tmp\Ramalho-182.pdf"
End If
Set filesys = Nothing
ActiveDocument.GetApplication.Sleep 3000
' '===========================================================================================
' ' Inicio das configuracoes do EMAIL
Porta = GetVariable("smtpPorta")
Server = GetVariable("smtpServer")
Usuario = GetVariable("smtpUser")
Senha = GetVariable("smtpPWD")
Origem = GetVariable("smtpOrigem")
Set objEmail = CreateObject("CDO.Message")
Set objConf = objEmail.Configuration
Set objFlds = objConf.Fields
With objFlds
'---------------------------------------------------------------------
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = Server
if len(Usuario) > 0 then
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = Usuario
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = Senha
else
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 0
end if
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = Porta
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = 90
.Update
'---------------------------------------------------------------------
End With
'Destinatarios = TabelaEmails.Item(contEmail).Text
Destinatarios = "xxxxcardim@gmail.com"
'Destinatarios = "xxxxxxxx@gmail.com"
objEmail.To = Destinatarios
objEmail.CC = "xxxxxxx@gmail.com"
objEmail.From = "xxxxx@gmail.com"
objEmail.Subject = "teste."
objEmail.HTMLBody = "teste."
'===========================================================================================
'Aqui colocamos os anexos.....
objEmail.AddAttachment "C:\tmp\Relatorio1.pdf"
objEmail.AddAttachment "C:\tmp\Relatorio2.pdf"
objEmail.AddAttachment "C:\tmp\Geral.pdf"
objEmail.AddAttachment "C:\tmp\Tiradentes-82.pdf"
objEmail.AddAttachment "C:\tmp\Brasil-282.pdf"
objEmail.AddAttachment "C:\tmp\Ramalho-182.pdf"
'===========================================================================================
objEmail.Send
'===========================================================================================
'Aqui apagamos os arquivos pois senao da erro na proxima vez.....
'ActiveDocument.Save
ActiveDocument.GetApplication.Sleep 3000
'Next
'ActiveDocument.Fields("Gerente").Clear ' Limpar Filtro por Email
End Sub
Neves
