none
[NÃO É UMA PERGUNTA] Hyperlink de E-mail (do Outlook) em Planilha RRS feed

  • Pergunta

  • Oi pessoal só estou guardando o código aqui que vou usar em outro ambiente:

    Sub Emails_Outlook()
    
    '1) Conta quantos arquivos tem na pasta que o e-mail vai ser salvo para ser usado como hiperlink:
    Dim xFolder As String
    Dim xPath As String
    Dim xCount As Long
    Dim xFiDialog As FileDialog
    Dim xFile As String
    xFolder = "C:\temp\Emails Salvos\"
    If xFolder = "" Then Exit Sub
    xPath = xFolder & "\*.msg"
    xFile = Dir(xPath)
    Do While xFile <> ""
    xCount = xCount + 1
    xFile = Dir()
    Loop
    
    '2) Macro de Carregar os Emails da Caixa para a Planilha:
    'Carregar e-mails do outlook para o excel
    Dim appOutlook As Object
    Dim olNS As Object
    Dim olFolder As Object
    Dim olItem As Object
    Dim r As Long
    On Error Resume Next
    
    Set appOutlook = GetObject(, "Outlook.Application")
    If appOutlook Is Nothing Then
    Set appOutlook = CreateObject("Outlook.Application")
    End If
    
    On Error GoTo 0
    
    Set olNS = appOutlook.GetNamespace("MAPI")
    
    Set olFolder = olNS.Folders("jeniffer.oliveira26@hotmail.com").Folders("Rascunhos")
    'Cells.Delete
    UltimaLinha = Sheets("Painel").Cells(Rows.Count, 1).End(xlUp).Row
    r = UltimaLinha
    
    'Cria um array montando o título das colunas no arquivo.
    ThisWorkbook.Sheets("Painel").Activate
    'Range("A1:B1") = Array("Data e Hora", "Título")
    
    For Each olItem In olFolder.Items
    If TypeName(olItem) = "MailItem" Then
    r = r + 1
    Cells(r, "A") = olItem.ReceivedTime 'Data/Hora de recebimento
    Cells(r, "B") = olItem.Subject 'Assunto do e-mail
    
        'Salva essa mensagem de e-mail na Rede:
    Titulo = "MailItem" & xCount
    Endereco = "C:\temp\Emails Salvos\" & Titulo & ".msg"
        olItem.SaveAs Endereco
    
        'Cria um Hyperlink com a Mensagem de E-mail:
    With Worksheets("Painel")
     .Hyperlinks.Add Anchor:=.Range("B" & r), Address:=Endereco, TextToDisplay:=olItem.Subject
    End With
        xCount = xCount + 1
    Application.StatusBar = r
    End If
    
    Next olItem
    Columns.AutoFit
    
    '1) Envia os Dados para Planilha PAINEL:
        'Verifica qual é a UltimaLinha Preenchida da planilha PAINEL:
    UltimaLinha = Sheets("Painel").Cells(Rows.Count, 1).End(xlUp).Row
     
        'Seleciona a célula na coluna A corresponde a ultima linha + 1 preenchida:
    ThisWorkbook.Sheets("Painel").Activate
    Linha = UltimaLinha + 1
    Cells(Linha, 1).Select
    
        'Remove as duplicatas
    'Por Default, o VBA mantém o primeiro registro e delete o segundo (duplicado)
    UltimaLinha = Sheets("Painel").Cells(Rows.Count, 1).End(xlUp).Row
    ThisWorkbook.Sheets("Painel").Range("A1:B" & UltimaLinha).RemoveDuplicates Columns:=Array(1, 2), Header:=xlYes
    UltimaLinha = Sheets("Painel").Cells(Rows.Count, 1).End(xlUp).Row
    LinhaLimpa = UltimaLinha + 1
    Rows(LinhaLimpa).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    
        'Classifica do mais ANTIGO para o mais NOVO:
        
        
        'Redefine a Formatação da Planilha:
    Sheets("TabelaFormat").Activate
    Cells.Select
    Selection.Copy
    Sheets("Painel").Activate
    Cells.Select
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, _
    SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
        
    '3) Apaga as mensagens de E-mail do Diretório que estão Concluidas
        'Critério: Arquivos com + 10 dias
    
    
    MsgBox ("Atualização de E-mails Finalizada")
    End Sub
    
    

    quinta-feira, 4 de abril de 2019 03:24