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.