Vou compartilhar com vocês uma das coisas mais satisfatórias que consegui fazer nas minhas necessidades hoje, uma app Qlik que Exporta, selecion,reduz dados, roda excel, envia email (outlook). Bom, vou compartilhar o que tem no módulo, porque o restante é o básico do Qlik ( criação de tabelas, visões , etc).
sub Exporta_Dashboard ()
ActiveDocument.UnlockAll
ActiveDocument.ClearAll
Set Ultimo_Mes_Selecao = ACTIVEDOCUMENT.VARIABLES("ULTIMO_MES2")
ActiveDocument.Fields("Datinha").select Ultimo_Mes_Selecao.GetContent.string
'ActiveDocument.ReduceData
'ActiveDocument.Save
vCaminho = "caminho para onde haverá a exportação"
linha = 6
coluna = 3
Dim export()
Redim export(linha,coluna)
export(1,1) = "CH01"
export(1,2) = "INDICADORES 1.txt"
export(2,1) = "CH02"
export(2,2) = "FINALIZACOES 1.txt"
export(3,1) = "CH06"
export(3,2) = "INDICADORES 3.txt"
export(4,1) = "CH05"
export(4,2) = "FINALIZACOES 3.txt"
export(5,1) = "CH03"
export(5,2) = "ACOES .txt"
export(6,1) = "CH07"
export(6,2) = "HIGIENIZACAO .txt"
for a = 1 to linha
ExportaObjetoArquivo 5, export(a,1), vCaminho, export(a,2)
next
Call em1qlik
'ActiveDocument.GetApplication.Quit
end sub
Function ExportaObjetoArquivo(vTipoArquivo, vObjectExport, vCaminhoExp, vNomeArquivo)
Dim vPathFileArquivo
vPathFileArquivo = vCaminhoExp & vNomeArquivo
Set Graph = ActiveDocument.GetSheetObject(vObjectExport)
Select Case vTipoArquivo
Case 1 'XLS
Graph.ExportBiff vPathFileArquivo
Case 2 'Html
Graph.ExportHtml vPathFileArquivo
Case 3 'Bitmap
Graph.ExportBitmapToFile vPathFileArquivo
Case 4 'QVD
Graph.ExportEx vPathFileArquivo, 4
Case 5 'TEXTO
Graph.Export vPathFileArquivo,";"
End Select
End Function
sub em1qlik 'aqui o modulo da o comando que roda a mascara em excel
StrArquivoMascara = "caminho da mascara excel.xlsm"
set XLApp = CreateObject("Excel.Application")
ActiveDocument.GetApplication.WaitForIdle
set XLDOC = XLApp.Workbooks.Open(StrArquivoMascara) : XLApp.Visible = True
ActiveDocument.GetApplication.WaitForIdle
ActiveDocument.ClearCache
'XLApp.Calculate
ActiveDocument.GetApplication.WaitForIdle
XLApp.Run ("nome da macro que faca tudo que tem que fazer na mascara excel")
ActiveDocument.GetApplication.WaitForIdle
'XLDOC.Worksheets("Home").Range("A1").Select
XLApp.DisplayAlerts = False '': XLApp.Calculation = xlAutomatic
'XLDOC.SaveAs StrAttachment,51
XLDOC.Close : XLApp.DisplayAlerts = True : XLApp.Quit
Call email
end sub
sub email
PathImg = """Imagem que fica no final da sua assinatura de emaill.png"""
vSendTo = "johnatan@ficticio.com"
vAssunto = "Relatório Documento Qlik: " & date()
StrAttachment = "Caminho onde a mascara salvou o arquivo que o QLik rodou.xlsb" 'Aqui anexa o arquivo.
HTML = "Bom dia! <BR> <p> Relatório Documento Qlik. <BR> <BR> Atenciosamente, <BR> <hr> <BR> Aqui voce pode redigir o corpo do email ou colocar a sua assinatura."
HTML = HTML & "<BR>" & "<img src=" & PathImg & "alt=" & """" & "Mountain View" & """" & "style=" & """" & "width:1px;height:2px;" & """" & ">" & "<BR>"
Call SendMailHtml_SMTP(vSendTo, vAssunto, HTML, StrAttachment, "")
end sub
Public Function SendMailHtml_SMTP(SendTo, Subject, Body, Attachment, vImagePath) ', cdoBasic, EmailFrom, EmailFromName, SMTPServer, SMTPPassword, SMTPPort)
cdoBasic = 1 '1=BASIC clear text authentication 0=anonymous
EmailFrom = "seu email aqui"
EmailFromName = "Nome que vai vim no front .Exemplo: Relatorio FCC"
SMTPServer = "outlook.office365.com"
SMTPPassword = "senha do email"
SMTPPort = 25 '587
'##################################################
Const cdoSendUsingPickup = 1 'Send message using local SMTP service pickup directory.
Const cdoSendUsingPort = 2 'Send the message using SMTP over TCP/IP networking.
Const cdoAnonymous = 0 ' No authentication
Const cdoNTLM = 2 ' NTLM, Microsoft proprietary authentication
'##################################################
Const SMTPSSL = True
Const SendUsing = 2
Const SMTPConnectionTimeout = 60
'##################################################
From = """" & EmailFromName & """ <" & EmailFrom & ">"
SMTPLogon = EmailFrom
'##################################################
Dim iMsg
Set iMsg = CreateObject("CDO.Message")
With iMsg.Configuration.Fields
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = SendUsing
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = SMTPServer
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = SMTPPort
Select Case cdoBasic
Case 1
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = SMTPSSL
.Item("http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout") = SMTPConnectionTimeout
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = SMTPLogon
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = SMTPPassword
End Select
.Update
End With
If(Not "" = vImagePath) Then
Set objBP = iMsg.AddRelatedBodyPart(vImagePath, NomeArquivoPath(vImagePath), CdoReferenceTypeName) : objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & NomeArquivoPath(vImagePath) & ">" : objBP.Fields.Update
End If
With iMsg
.From = From
.To = SendTo
.Subject = Subject
.HTMLBody = Body
If(Not "" = Attachment) Then
.AddAttachment Attachment
End If
.Send
End With
If Err Then
'MsgBox "SendMail Failed:" & Err.Description
End If
Set iMsg = Nothing
End Function
'####################################################################################################################################################
Public Function NomeArquivoPath(vStrFullPath)
NomeArquivoPath = StrReverse(Mid(StrReverse(vStrFullPath), 1, InStr(1, StrReverse(vStrFullPath), "\")-1))
End Function
'###############
Dúvidas estou a disposição.
