Skip to main content
Announcements
NEW Customer Portal: Initial launch will improve how you submit Support Cases. FIND OUT MORE
cancel
Showing results for 
Search instead for 
Did you mean: 
Anonymous
Not applicable

Macro - Exporta, selecion,reduz dados, roda excel, envia email (outlook)

E ai tudo bem?

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).

Módulo:

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.

Labels (3)
1 Reply
lucianosv
Specialist
Specialist

Boa tarde.

Fiquei com dúvida sobre as datas.

ULTIMO_MES2 é uma data do qvw? E Datinha?


Afinal o que temos que setar e o que é da aplicação?

Também não entendi sobre o arquivo máscara. Precisamos construir a máscara?


Grato, Luciano.