Ir ao conteúdo
Regras do Clube do Hardware

Excel Escolher arquivo antes de envia e-mail VBA

Zamboni_du

Por Zamboni_du
em Microsoft Office e similares

 Compartilhar
Ir à solução Resolvido por Midori,

Posts recomendados

Zamboni_du
 

Zamboni_du

Postado
Postado

Bom dia!!!!

 

Eu tenho uma aplicação para enviar e-mail direto do Excel, porém eu preciso em alguns casos escolher o anexo. Utilizando o método Attachments.Add eu consigo anexar um arquivo específico porém eu necessito que seja aberta a caixa de diálogo para que eu escolha o arquivo,

Zamboni_du
 

Zamboni_du

Postado
  • Autor
Postado
Em 19/04/2024 às 10:35, Zamboni_du disse:

Bom dia!!!!

 

Eu tenho uma aplicação para enviar e-mail direto do Excel, porém eu preciso em alguns casos escolher o anexo. Utilizando o método Attachments.Add eu consigo anexar um arquivo específico porém eu necessito que seja aberta a caixa de diálogo para que eu escolha o arquivo,

O código abaixo a caixa de diálogo para escolher o arquivo porém não anexa.

  

With ActiveSheet.MailEnvelope
      
      On Error Resume Next
Set xApp = CreateObject("Excel.Application")
xApp.Visible = False
Set xFileDlg = xApp.Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.InitialFileName = "C:\Users\Win10x64Test\Desktop\save attachments\"  'Specify the path to the folder you want to open
xFileDlg.AllowMultiSelect = True
If xFileDlg.Show = 0 Then GoTo L1
Set xMail = Application.ActiveInspector.CurrentItem
For Each xSelItem In xFileDlg.SelectedItems
    xMail.Attachments.Add xSelItem
Next
L1:
    xApp.Quit
    Set xFileDlg = Nothing
    Set xApp = Nothing

 

Zamboni_du
 

Zamboni_du

Postado
  • Autor
Postado

@Midori @Midori Boa tarde!!!!

 

Segue abaixo:

 

Sub enviar_corpo_email()

Dim BR As Variant, dtToday As String, Anexo As Variant

Dim xApp As Object
Dim xFileDlg As FileDialog
Dim xSelItem As Variant
Dim xMail As MailItem

 

'Organiza em Ordem numérica campo Referência
Planilha4.ListObjects("Tabela8").Sort.SortFields.Clear
    Planilha4.ListObjects("Tabela8").Sort.SortFields.Add2 _
        Key:=Range("Tabela8[[#All],[Referência]]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortTextAsNumbers
    With Planilha4.ListObjects("Tabela8").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

 

'Seleciona o intervalo de células a serem enviadas por email.

Planilha3.Select

   Planilha3.Range("A4:H28").Select
   
   ActiveWorkbook.EnvelopeVisible = True

Set BR = Planilha12.Range("J3")
dtToday = Date
   
   With ActiveSheet.MailEnvelope
      
      'On Error Resume Next
Set xApp = CreateObject("Excel.Application")
xApp.Visible = False
Set xFileDlg = xApp.Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.InitialFileName = "C:\Users\" & Environ("UserName") & "\"C:\Users\Win10x64Test\Desktop\save attachments\"  'Specify the path to the folder you want to open
xFileDlg.AllowMultiSelect = True
If xFileDlg.Show = 0 Then GoTo L1
Set xMail = Application.ActiveInspector.CurrentItem <- linha onde está apresentando o Erro em tempo de execução '438: Objeto não aceita esta propriedade ou método
For Each xSelItem In xFileDlg.SelectedItems
    xMail.Attachments.Add xSelItem
Next
L1:
    xApp.Quit
    Set xFileDlg = Nothing
    Set xApp = Nothing

      .Item.To = Planilha11.Range("C21")

      .Item.Subject = "Rotas " & BR
         
      .Item.Display
      
      '.Item.Send

   End With
   
'Planilha10.Select

End Sub
 

Midori
 

Midori

Postado
Postado
2 horas atrás, Zamboni_du disse:

Set xMail = Application.ActiveInspector.CurrentItem <- linha onde está apresentando o Erro

Esse erro acontece quando não há nenhum item/objeto para referenciar no seu ambiente. O item é a janela do MS Outlook da opção Novo Email. Você pode abrir essa janela manualmente antes de rodar a macro ou criar assim,

  

Set xMail = Application.CreateItem(olMailItem)
xMail.Display

 

A nova atribuição para xMail.

Midori
 

Midori

Postado
Postado

Seu código a partir de "Set xApp"... é a macro para o MS Outlook. Se quer enviar o email a partir do Excel você pode fazer CreateObject do Outlook para chamar suas propriedades e métodos.

Zamboni_du
 

Zamboni_du

Postado
  • Autor
Postado

@Midori @Midori , Enviar o email com as informações no corpo está funcionando corretamente, o que gostaria que aparecesse a opção de escolher um ou vários arquivo para anexar no email. O código abaixo deveria fazer isso porém não está fazendo 😢.

 

Set xApp = CreateObject("Excel.Application")
xApp.Visible = False
Set xFileDlg = xApp.Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.InitialFileName = "C:\Users\" & Environ("UserName") & "\"C:\Users\Win10x64Test\Desktop\save attachments\"  'Specify the path to the folder you want to open
xFileDlg.AllowMultiSelect = True
If xFileDlg.Show = 0 Then GoTo L1
Set xMail = Application.ActiveInspector.CurrentItem <- linha onde está apresentando o Erro em tempo de execução '438: Objeto não aceita esta propriedade ou método
For Each xSelItem In xFileDlg.SelectedItems
    xMail.Attachments.Add xSelItem
Next
L1:
    xApp.Quit
    Set xFileDlg = Nothing
    Set xApp = Nothing

Midori
 

Midori

Postado
Postado

Está funcionando o envio com MailEnvelope e não com os objetos do MS Outlook. É o que acontece com ActiveSheet.MailEnvelope.Item.Send.

 

Na documentação do MailEnvelope não vi um membro para adicionar anexos. Para isso, a partir do Excel, você pode usar os objetos do MS Outlook mesmo em vez de MailEnvelope e acredito que já tenha acrescentado a referência já que o código não tem CreateObject para o Outlook.

 

Aqui no fórum tem exemplos de como enviar email assim, veja se este ajuda,

 

 

Zamboni_du
 

Zamboni_du

Postado
  • Autor
Postado

@Midori , bom dia!!!!

 

Segue o código completo:

 

Option Explicit
Function Saudacao() As String

    Dim Hora As Date
    
    Hora = Format(Now, "HH:MM:SS")
   
    Select Case Hora
        Case "00:00:00" To "11:59:59"
            Saudacao = "Bom dia,"
        Case "12:00:00" To "17:59:59"
            Saudacao = "Boa tarde,"
        Case Else
            Saudacao = "Boa noite,"
    End Select

End Function

 

Sub enviar_corpo_email()

Dim BR As Variant, dtToday As String, Anexo As Variant

Dim xApp As Object
Dim xFileDlg As FileDialog
Dim xSelItem As Variant
Dim xMail As MailItem

'Ordem numérica SQ01 Referência
Planilha4.ListObjects("Tabela8").Sort.SortFields.Clear
    Planilha4.ListObjects("Tabela8").Sort.SortFields.Add2 _
        Key:=Range("Tabela8[[#All],[Referência]]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortTextAsNumbers
    With Planilha4.ListObjects("Tabela8").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Seleciona o intervalo de células a serem enviadas por email.

Planilha3.Select

   Planilha3.Range("A4:H28").Select
   
   ActiveWorkbook.EnvelopeVisible = True

Set BR = Planilha12.Range("J3")
dtToday = Date
   
   With ActiveSheet.MailEnvelope
      
      'On Error Resume Next
Set xApp = CreateObject("Excel.Application")
xApp.Visible = False
Set xFileDlg = xApp.Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.InitialFileName = "C:\Users\Win10x64Test\Desktop\save attachments\"  
xFileDlg.AllowMultiSelect = True
If xFileDlg.Show = 0 Then GoTo L1
Set xMail = Application.ActiveInspector.CurrentItem
For Each xSelItem In xFileDlg.SelectedItems
    xMail.Attachments.Add xSelItem
Next
L1:
    xApp.Quit
    Set xFileDlg = Nothing
    Set xApp = Nothing

      .Item.To = Planilha11.Range("C21")

      .Item.Subject = "Rotas " & BR
      .Item.Display
      '.Item.Send

   End With
   
End Sub
 

Midori
 

Midori

Postado
Postado

O código continua praticamente o mesmo, é como se não tivesse lido o que escrevi...

 

Ainda está com MailEnvelope e CurrentItem.

 

Veja se tem alguma dúvida sobre o que já foi dito.

Zamboni_du
 

Zamboni_du

Postado
  • Autor
Postado

@Midori , eu fiz a alteração e como mencionei logo abaixo do que você escreveu o mesmo erro aconteceu. porém pode ser que eu não tenha entendio o que você descreveu, segue abaixo com a alteração que você mencionou:

 

Sub enviar_corpo_email()

Dim BR As Variant, dtToday As String, Anexo As Variant

Dim xApp As Object
Dim xFileDlg As FileDialog
Dim xSelItem As Variant
Dim xMail As MailItem

'Ordem numérica SQ01 Referência
Planilha4.ListObjects("Tabela8").Sort.SortFields.Clear
    Planilha4.ListObjects("Tabela8").Sort.SortFields.Add2 _
        Key:=Range("Tabela8[[#All],[Referência]]"), SortOn:=xlSortOnValues, Order _
        :=xlAscending, DataOption:=xlSortTextAsNumbers
    With Planilha4.ListObjects("Tabela8").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

'Seleciona o intervalo de células a serem enviadas por email.

Planilha3.Select

   Planilha3.Range("A4:H28").Select
   
   ActiveWorkbook.EnvelopeVisible = True

Set BR = Planilha12.Range("J3")
dtToday = Date
   
   With ActiveSheet.MailEnvelope
      
      'On Error Resume Next
Set xApp = CreateObject("Excel.Application")
xApp.Visible = False
Set xFileDlg = xApp.Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.InitialFileName = "C:\Users\" & Environ("UserName") & "\Documents\SAP\SAP GUI" '"C:\Users\Win10x64Test\Desktop\save attachments\"  'Specify the path to the folder you want to open
xFileDlg.AllowMultiSelect = True
If xFileDlg.Show = 0 Then GoTo L1
Set xMail = Application.CreateItem(olMailItem)

xMail.Display
For Each xSelItem In xFileDlg.SelectedItems
    xMail.Attachments.Add xSelItem
Next
L1:
    xApp.Quit
    Set xFileDlg = Nothing
    Set xApp = Nothing

      .Item.To = Planilha11.Range("C21")

      .Item.Subject = "Rotas " & BR
         
      .Item.Display
      
      '.Item.Send

   End With
   
'Planilha10.Select

End Sub
 

  • Solução
Midori
 

Midori

Postado
  • Solução
Postado

 

5 horas atrás, Zamboni_du disse:

Set xMail = Application.CreateItem(olMailItem)

 

Assim é para o VBA do Outlook. Para o Excel a atribuição é como está lá no link que comentei.

 

***

 

Uma forma mais simples que fiz aqui foi atribuindo Item de MailEnvelope ao MailItem do Outlook (por isso a referência ao objeto deve estar selecionada),

  

Sub MacroEmail()
    Dim Email   As MailItem
    Dim Dialogo As FileDialog
    Dim Anexo   As Variant
    
    Set Email = ThisWorkbook.Sheets("Teste").MailEnvelope.Item
    Set Dialogo = Application.FileDialog(msoFileDialogFilePicker)
    Dialogo.AllowMultiSelect = True
    
    If Dialogo.Show <> 0 Then
        For Each Anexo In Dialogo.SelectedItems
            Call Email.Attachments.Add(Anexo)
        Next Anexo
    End If
    
    Email.To = ""
    Email.Subject = "Teste"
    Email.Send
End Sub

 

Assim vai a planilha no corpo do email com o anexo selecionado no diálogo.

 

Pode acontecer uma falha em MailEnvelope, para resolver isso é só salvar a planilha.

 

Zamboni_du
 

Zamboni_du

Postado
  • Autor
Postado

@Midori, bom dia!!!!

Eu preciso fazer um queno ajuste, enviar apenas um parte da planilha, da célula A4:H30 como eu faria? Eu tentei colocara direto na linha criar uma variável mas não funcionou 😅.

Midori
 

Midori

Postado
Postado
4 horas atrás, Zamboni_du disse:

enviar apenas um parte da planilha, da célula A4:H30 como eu faria?

Para isso faça a seleção das células com a planilha ativa, p.ex: ThisWorkbook.Sheets("Teste").[A4:H30].Select

  • Curtir 1

Crie uma conta ou entre para comentar

Você precisa ser um usuário para fazer um comentário

Criar uma conta

Crie uma nova conta em nossa comunidade. É fácil!

Crie uma nova conta

Entrar

Já tem uma conta? Faça o login.

Entrar agora
 Compartilhar
Ir à lista de tópicos

Sobre o Clube do Hardware

No ar desde 1996, o Clube do Hardware é uma das maiores, mais antigas e mais respeitadas comunidades sobre tecnologia do Brasil. Leia mais

Direitos autorais

Não permitimos a cópia ou reprodução do conteúdo do nosso site, fórum, newsletters e redes sociais, mesmo citando-se a fonte. Leia mais

Mais

×
×
  • Criar novo...