回复（通过.Send）电子邮件Outlook“运行脚本”规则不会触发传入消息的VBA脚本

时间：2019-03-26 18:45:12

标签： vba outlook outlook-vba

（由于我来自巴西，所以葡萄牙语中有一些文字，因此，如果您需要帮助，请告诉我。）

我的Outlook“此Outlook会话”中有2个宏，位于1个主宏中，该宏调用了我之前提到的其他2个。

  • 主宏执行：
    宏名称："Salvar_CNAB_Registro"

发现电子邮件的主题，并根据所写内容提供所需的路径。 发现路径后，将电子邮件中的所有附件保存在发现的路径上。

Sub Salvar_CNAB_Registro(Email As MailItem)     
    'Dim strSubject As String
    Dim objMsg As Outlook.MailItem
    Dim objSubject As String

    objSubject = Email.Subject

    'Defino qual caminho salvará os registros dos arquivos CNAB dependendo do produto da Funcesp ou da forma de liquidação
    If InStr(1, objSubject, "Registro de Boletos de Saúde - Vencimento") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201658\"
       'DiretorioAnexos = "K:\Divisao_Administrativa_Financeira\Tesouraria\Contas_Receber\COBRANÇAS\SAÚDE\2019\03 MARÇO 2019\25.03.2019\TESTE\"
    ElseIf InStr(1, objSubject, "Registro de Boletos de Autopatrocínio - Vencimento") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201658\"
    ElseIf InStr(1, objSubject, "Registro de Boletos de Seguros - Vencimento") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201717\"
    ElseIf InStr(1, objSubject, "Registro de Débito Automático de Saúde - Vencimento") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201775\"
    ElseIf InStr(1, objSubject, "Registro de Débito Automático de Autopatrocínio - Vencimento") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201775\"
    ElseIf InStr(1, objSubject, "Registro de Débito Automático de Seguros - Vencimento") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201775\"
    ElseIf InStr(1, objSubject, "Registro de Boletos de Empréstimo") > 0 Then
       DiretorioAnexos = "S:\AFTData\OUTBOX\GE201717\"
    End If

    Debug.Print "Diretório Macro Salvar_CNAB_Registro:"
    Debug.Print DiretorioAnexos

    Dim MailID As String
    Dim Mail As Outlook.MailItem

    MailID = Email.EntryID
    Set Mail = Application.Session.GetItemFromID(MailID)

    'Verifico se o anexo no e-mail é arquivo unixo TXT e salvo todos
    For Each Anexo In Mail.Attachments
        If Right(Anexo.FileName, 3) = "txt" Then
            Anexo.SaveAsFile DiretorioAnexos & "\" & Anexo.FileName
        End If
    Next

    'Verifico se o anexo no e-mail é arquivo unixo zip e salvo todos
    For Each Anexo In Mail.Attachments
        If Right(Anexo.FileName, 3) = "zip" Then
            Anexo.SaveAsFile DiretorioAnexos & Anexo.FileName
            Call Unzipar_Arquivos
        End If

    Next

    DoEvents
    Call Reply_Email

    Set Mail = Nothing
 End Sub
  • 第一个宏执行：
    宏名称：Unzipar_Arquivos（调用宏UnzipAFile）

它具有两个宏，它可以解压缩Outlook上规则所调用的任何电子邮件中附加的所有zip文件。

Sub UnzipAFile(zippedFileFullName As Variant, unzipToPath As Variant)

Dim ShellApp As Object

'Copy the files & folders from the zip into a folder
Set ShellApp = CreateObject("Shell.Application")
ShellApp.NameSpace(unzipToPath).CopyHere ShellApp.NameSpace(zippedFileFullName).Items

End Sub

Sub Unzipar_Arquivos()

Dim diretorio As Variant
Dim diretorio_ext As Variant
Dim nome_arquivo As String


'------------------------------------ Extraio os arquivos da pasta do Santander Outbox 1658 --------------------------------'


'Caminho que o arquivo será unzipado
diretorio_ext = "S:\AFTData\OUTBOX\GE201658\"

'Descobre o nome do arquivo zip + caminho que ele se encontra
nome_arquivo = Dir(diretorio_ext & "*.zip")

'Caminho que encontra-se o arquivo zipado
diretorio = "S:\AFTData\OUTBOX\GE201658\" & nome_arquivo

'Executo a macro enquanto houver arquivos zipados na pasta
Do While Len(nome_arquivo) > 0

    'A primeira parte refere-se ao nome do arquivo que será unzipado, e a segunda parte refere-se ao caminho que ele será unzipado
    Call UnzipAFile(diretorio, diretorio_ext)

    'Apago o primeiro arquivo zip que foi extraído
    'Primeiro remove o atributo de arquivo "somente leitura" caso esteja definido
    On Error Resume Next
    SetAttr FileToDelete, vbNormal
    'Depois apago o arquivo
    Kill diretorio

    'Procura o próximo arquivo
    nome_arquivo = Dir

    'Exibe mensagem de sucesso
    MsgBox "Arquivo " & nome_arquivo & "descompactado e arquivos registrados! " & "no diretório: " & diretorio_ext

Loop


'------------------------------------ Extraio os arquivos da pasta do Santander Outbox 1717 --------------------------------'


'Caminho que o arquivo será unzipado
diretorio_ext = "S:\AFTData\OUTBOX\GE201717\"

'Descobre o nome do arquivo zip + caminho que ele se encontra
nome_arquivo = Dir(diretorio_ext & "*.zip")

'Caminho que encontra-se o arquivo zipado
diretorio = "S:\AFTData\OUTBOX\GE201717\" & nome_arquivo

'Executo a macro enquanto houver arquivos zipados na pasta
Do While Len(nome_arquivo) > 0

    'A primeira parte refere-se ao nome do arquivo que será unzipado, e a segunda parte refere-se ao caminho que ele será unzipado
    Call UnzipAFile(diretorio, diretorio_ext)

    'Apago o primeiro arquivo zip que foi extraído
    'Primeiro remove o atributo de arquivo "somente leitura" caso esteja definido
    On Error Resume Next
    SetAttr FileToDelete, vbNormal
    'Depois apago o arquivo
    Kill diretorio

    'Procura o próximo arquivo
    nome_arquivo = Dir

    'Exibe mensagem de sucesso
    MsgBox "Arquivo " & nome_arquivo & "descompactado e arquivos registrados! " & "no diretório: " & diretorio_ext

Loop


'------------------------------------ Extraio os arquivos da pasta do Santander Outbox 1775 --------------------------------'


'Caminho que o arquivo será unzipado
diretorio_ext = "S:\AFTData\OUTBOX\GE201775\"

'Descobre o nome do arquivo zip + caminho que ele se encontra
nome_arquivo = Dir(diretorio_ext & "*.zip")

'Caminho que encontra-se o arquivo zipado
diretorio = "S:\AFTData\OUTBOX\GE201775\" & nome_arquivo

'Executo a macro enquanto houver arquivos zipados na pasta
Do While Len(nome_arquivo) > 0

    'A primeira parte refere-se ao nome do arquivo que será unzipado, e a segunda parte refere-se ao caminho que ele será unzipado
    Call UnzipAFile(diretorio, diretorio_ext)

    'Apago o primeiro arquivo zip que foi extraído
    'Primeiro remove o atributo de arquivo "somente leitura" caso esteja definido
    On Error Resume Next
    SetAttr FileToDelete, vbNormal
    'Depois apago o arquivo
    Kill diretorio

    'Procura o próximo arquivo
    nome_arquivo = Dir

    'Exibe mensagem de sucesso
    MsgBox "Arquivo " & nome_arquivo & "descompactado e arquivos registrados! " & "no diretório: " & diretorio_ext

Loop

End Sub
  • 第二个宏执行：
    宏名称：Reply_Email

发现之前保存的每个文件的名称，然后在将要答复所有内容的HTML电子邮件的正文中添加名称。 

Sub Reply_Email()

    Dim strFolder As String
    Const strPattern As String = "*.txt"
    Dim strFile As String
    Dim nome_cnab As String
    Dim quantidade As Integer
    Dim add_msg As String
    Dim validador As Integer
    Dim i As Integer

    Debug.Print "Diretório Macro Responder_Email:"
    Debug.Print strFolder
    'Define o nome do caminho de acordo com o assunto (produto da funcesp que o cnab está sendo registrado) do e-mail enviado pelo funcionário solicitando o registro
    strFolder = DiretorioAnexos
    'Define a quantidade inicial de arquivos dentro da pasta que foi registrada
    quantidade = 0
    'Define o validador inicial igual a 0, isso significa que ainda não começou a montar o e-mail de resposta para a pessoa
    validador = 0
'Nome do passo quando ele montar o e-mail, e adicionará os nomes dos arquivos cnab através do loop
Add_Nome_Cnab:
    strFile = Dir(strFolder & strPattern, vbNormal)
    Do While Len(strFile) > 0
        'Caso queira ver o nome do arquivo CNAB na janela de verificação imediata (CTRL + G)
        'Debug.Print strFile
        strFile = Dir
        nome_cnab = strFile
        'Adiciono 1 na quantidade toda vez que passar por aqui, assim teremos a quantidade de arquivos salvos de cada e-mail
        quantidade = quantidade + 1
        'Se o validador for 1, ele grava o nome do arquivo na variavel
        If validador = 1 Then
            add_msg = nome_cnab
            'Vai para o passo de adicionar de fato o nome do arquivo no corpo do e-mail através da variavel criada acima
            GoTo Check_Validador
        End If
    Loop

    Dim olItem As Outlook.MailItem
    Dim olReply As MailItem ' Reply

    For Each olItem In Application.ActiveExplorer.Selection
        Set olReply = olItem.ReplyAll
        'Define o validador como 1, para começar a montar o e-mail
        validador = 1
        'Se tiver 1 arquivo ou mais, ele começa a montar o e-mail
        If quantidade > 0 Then
            For i = 1 To quantidade
                'Vai para o passo de gravar o nome do arquivo na variavel
                GoTo Add_Nome_Cnab
Check_Validador:
                'Essa etapa que ele adiciona de fato o nome no corpo do e-mail através da variavel criada acima
                olReply.HTMLBody = "<br>" & add_msg & vbCrLf & olReply.HTMLBody
                DoEvents
            Next i
        Else
            olReply.HTMLBody = "<br>" & "Nenhum arquivo CNAB registrado" & "<br>" & vbCrLf & olReply.HTMLBody
        End If
            'Escreve as duas primeiras linhas no corpo do e-mail: "Arquivos registrados no dia e hora: " + Data e Hora + "Segue arquivos registrados: "
            olReply.HTMLBody = "<br>" & "Arquivos registrados no dia e hora: " & Now & "<br>" & "Segue arquivos registrados: " & "<br>" & vbCrLf & olReply.HTMLBody
            DoEvents
            'Mostra o e-mail na tela
            olReply.Display
            DoEvents
            'Envia o e-mail
            olReply.Send
            DoEvents
    Next olItem
End Sub

所有宏都单独起作用，但是我的问题是，当主宏“ Salvar_CNAB_Registro”调用最后一个宏（Reply_Email）时，电子邮件本身不会自动发送。

因此，如果我单独运行脚本，它将起作用！！！但是，它不能被另一个宏调用。

编辑1：

我做了一些测试，但是除非调试，否则仍然无法正常工作。

我做了什么：

添加了宏以一起测试所有宏，每个宏都相互调用。

子测试（）     昏暗的x，mailItem为Outlook.mailItem     对于每个x In Application.ActiveExplorer.Selection         如果TypeName（x）=“ MailItem”，则             设置mailItem = x             致电Salvar_CNAB_Registro（mailItem）         万一     下一个 结束

因此，仍然可以通过调试发送电子邮件，但不能通过从规则中调用来发送电子邮件。我的意思是，所有宏都有效，但仅不显示和发送电子邮件。

我尝试了@ 0m3r的解决方案，使用了Application.ActiveExplorer.Selection从宏Reply_Email中删除了行Sub Reply_Email(ByVal Email As Object)，然后像Reply_Email(Email)一样调用了它，但是这种方法没有工作。

我什至尝试使用Sub Reply_Email(Email As Outlook.mailItem)，然后像Reply_Email(Email)那样调用它，该方法通过再次调试起作用，但不是自动进行的。

我还尝试了这种方法（How to Auto Reply with Outlook rule），方法是直接从规则中回复电子邮件，但正文中的原始消息不存在，因此我也无法在工作中签署此代码。 / p>

1 个答案:

答案 0 :(得分：1)

成功了！我遵循了@ 0m3r的提示，并且我在网络上进行了一些研究以尝试解决此问题。

我做了什么：

现在，我的宏为[("HARPER'S", '[Day 1, 9:00 A.M.]', 'When the computer was young, the word hacking was\nused to describe the work of brilliant students who explored and expanded the\nuses to which this new technology might be employed. There was even talk of a\n"hacker ethic." Somehow, in the succeeding years, the word has taken on dark\nconnotations, suggestion the actions of a criminal. What is the hacker ethic,\nand does it survive? '), ('ADELAIDE', '[Day 1, 9:25 A.M.]', "the hacker ethic survives, and it is a fraud. It\nsurvives in anyone excited by technology's power to turn many small,\ninsignificant things into one vast, beautiful thing. It is a fraud because\nthere is nothing magical about computers that causes a user to undergo\nreligious conversion and devote himself to the public good. Early automobile\ninventors were hackers too. At first the elite drove in luxury. Later\npractically everyone had a car. Now we have traffic jams, drunk drivers, air\npollution, and suburban sprawl. The old magic of an automobile occasionally\nsurfaces, but we possess no delusions that it automatically invades the\nconsciousness of anyone who sits behind the wheel. Computers are power, and\ndirect contact with power can bring out the best or worst in a person. It's\ntempting to think that everyone exposed to the technology will be grandly\ninspired, but, alas, it just ain't so."), ('BRAND', '[Day 1, 9:54 A.M.]', "The hacker ethic involves several things. One is\navoiding waste; insisting on using idle computer power -- often hacking into a\nsystem to do so, while taking the greatest precautions not to damage the\nsystem. A second goal of many hackers is the free exchange of technical\ninformation. These hackers feel that patent and copyright restrictions slow\ndown technological advances. A third goal is the advancement of human\nknowledge for its own sake. Often this approach is unconventional. People we\ncall crackers often explore systems and do mischief. The are called hackers by\nthe press, which doesn't understand the issues."), ('KK', '[Day 1, 11:19 A.M.]', 'The hacker ethic went unnoticed early on because the\nexplorations of basement tinkerers were very local. Once we all became\nconnected, the work of these investigations rippled through the world. today\nthe hacking spirit is alive and kicking in video, satellite TV, and radio. In\nsome fields they are called chippers, because the modify and peddle altered\nchips. Everything that was once said about "phone phreaks" can be said about\nthem too.')] ，我仅命名了Sub Reply_Email(ByVal Email As Object)和Dim olReply As mailItem。

我看到的主要区别是这部分：

Set olReply = Email.ReplyAll

因此，添加此内容后，电子邮件已发送。该宏由With olReply 'Envia o e-mail .Send End With 调用。

最后，我添加了一条规则，如果主题中包含单词Call Reply_Email(Email)或"ENC:"，则该电子邮件将不回复电子邮件，这意味着如果其中包含一些回复电子邮件收件箱，它什么也不会做。

相关问题
最新问题