激活电子邮件中包含的特定URL-进行2 [英] Activate specific URL contained in an email message - Take 2

问题描述

首先，感谢所有已经帮助完成此消息的第一次迭代的人。在浏览了其他站点之后，我在此页面上找到了一种使用正则表达式搜索URL消息的更好方法，在slipstick.com上打开Outlook电子邮件中的所有超链接。

First, thanks to all who have already assisted in the first iteration of this message. After looking around at other sites I found a better method for searching messages for URLs using regular expressions on this page, Open All Hyperlinks in an Outlook Email Message, on slipstick.com.

我个人对代码的调整是：

The my personal tweaking of the code is:

Option Explicit

Public Sub OpenLinksMessage()

 Dim olMail As Outlook.MailItem
 Dim Reg1 As RegExp
 Dim AllMatches As MatchCollection
 Dim M As Match
 Dim strURL As String
 Dim oApp As Object

 Set oApp = CreateObject("InternetExplorer.Application")

 Set olMail = ActiveExplorer.Selection(1)

 Set Reg1 = New RegExp

'Set the Regular Expression to search for any http:// or https:// format URL
'The Global feature says to look through the entire message text being tested
With Reg1
 .Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
 .Global = True
 .IgnoreCase = True
End With

' If the regular expression test for URLs comes back true
If Reg1.test(olMail.Body) Then

'      Use the RegEx to return all instances that match it to the AllMatches group
       Set AllMatches = Reg1.Execute(olMail.Body)
       For Each M In AllMatches
               strURL = M.SubMatches(0)
'              Don't activate any URLs that are for unsubscribing; skip them
               If InStr(strURL, "unsubscribe") Then GoTo NextURL
'              If the URL ends with a > from being enclosed in darts, strip that > off
               If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
'              We now have a URL that we want to open in a new tab in IE
               oApp.navigate strURL, CLng(2048)
               oApp.Visible = True

' wait for page to load before passing the web URL
  Do While oApp.Busy
    DoEvents
  Loop

  NextURL:
     Next
End If

Set Reg1 = Nothing

End Sub

Private Sub TestLaunchURL()
    OpenLinksMessage
End Sub

这将在Windows 10下运行我想知道是否有某种方法可以代替该语句：

This will be running under Windows 10, and I am wondering if there is some way to substitute the statement:

 Set oApp = CreateObject("InternetExplorer.Application")

以及与之等效的功能，但是否可以抓住用户选择作为默认Web浏览器的应用程序？我也不确定Clng（2048）进行必要的更改以传达我希望在该浏览器的新标签页（而不是当前具有焦点的标签页）中打开该URL。

with its equivalent but snagging the application that the user has chosen as their default web browser? I'm also not certain of what, if any change, would be necessary to the Clng(2048) to communicate that I'd like the URL to be opened in a new tab of that browser rather than the one that currently has focus.

将：

Set olMail = ActiveExplorer.Selection(1)

当由 a触发时，是我刚刚收到的消息的正确语法传入消息的规则？如果不是，那是什么？

be the correct syntax for the "message I've just received" when this is being triggered by a rule for an incoming message? If not, what is?

DO循环真的必要吗？我正在尝试了解它的作用，但实际上还没有。

Is that DO loop really necessary? I am trying to get a handle on what it does but really don't have it yet.

从特定电子邮箱收到的邮件中应该只有一个链接应当为链接解析并打开的邮件地址，但是对此的测试应该在调用此子例程的规则中，而不是在VBA代码本身中。我可能还有一些其他的过滤逻辑，但是我认为这将是添加一个或两个IF语句的问题。

There should only be a single link in messages received from a specific e-mail address that should be parsed for the link and opened, but the test for that should be in the rule that invokes this subroutine rather than in the VBA code itself. I may have some additional filtering logic, but I think it will be a matter of adding an IF statement or two.

如果有人在此改编的代码中发现任何明显的错误，请让我知道。 IE打开后，似乎正在对单个邮件进行测试，并且邮件中的每个链接都在其自己的标签中打开。我真的很想尽可能在​​用户的默认网络浏览器中打开它。

If anyone sees any glaring error in this adapted code please do let me know. It seems to be working on tests on individual messages, as IE opens and every link that's in the message is being opened in its own tab. I'd really like to make it open in the user's default web browser if at all possible.

在此先感谢您的帮助。

Thanks in advance for your assistance. It has been invaluable already.

阶段2：脚本经过了全面测试，可以正常工作。它已安装在Outlook 2016下，我们使用通过selfcert创建的证书对其进行了签名，信任中心宏权限仍然位于数字签名宏的通知，所有其他宏均已禁用。

Phase 2: The script is thoroughly tested and works. It has been installed under Outlook 2016, we signed it with a certificate created with selfcert, the Trust Center Macro permissions are still at "Notifications for digitally signed macros, all other macros disabled."

运行调用脚本的规则并触发脚本时，会出现以下错误消息框：

When the the rule that invokes the script is run, and the script is triggered, the following error message box appears:

VBA错误消息框

关于出问题的任何理论以及如何解决？我还没有使用selfcert创建第二个证书，并再次对其进行了签名，因为我想知道是否有时由于其他原因而弹出此错误消息。

Any theories on what went wrong and how to fix it? I have not yet created a second certificate with selfcert and signed this again because I wanted to know if this error message might pop up for other reasons, as sometimes happens.

也，我是否相信如果签名的话，用户签名的用户创建的宏将运行，而不管宏安全性设置为什么，除非设置为禁用所有宏？

Also, am I correct in believing that signed, user created macros will run, if signed, regardless of what the macro security is set to unless the setting is "all macros disabled"?

阶段3.5（多种）

问题的根源在于脚本本身未在运行当有新消息到达时。我设置了一个测试规则，该规则最初是播放声音并在发件人地址中包含两个地址之一的邮件到达时调用脚本。声音会持续播放，但没有其他任何反应。因此，我想，让我们从Outlook规则中删除播放声音，并将其放在脚本本身中，然后在脚本开始时无条件播放一个声音。好吧，娜达这是最新的代码（其中一些直接从stackoverflow上的先前线程获取）：

It appears the root of the problem is that the script itself is not being run at all when a new message arrives. I set up a testing rule that initially was to play a sound and invoke the script when a message arrives with either of two addresses in the sender's address. The sound would consistently play, but nothing else happened. So, I thought, let's take the sound playing out of the Outlook rule and put it in the script itself, with one sound playing unconditionally at the start of the script. Well, nada. Here is the latest code (some of which is taken directly from prior threads here on stackoverflow):

Option Explicit

Private Declare Function ShellExecute _
  Lib "shell32.dll" Alias "ShellExecuteA" ( _
  ByVal hWnd As Long, _
  ByVal Operation As String, _
  ByVal Filename As String, _
  Optional ByVal Parameters As String, _
  Optional ByVal Directory As String, _
  Optional ByVal WindowStyle As Long = vbMinimizedFocus _
  ) As Long

Private Declare Function sndPlaySound32 _
    Lib "winmm.dll" _
    Alias "sndPlaySoundA" ( _
        ByVal lpszSoundName As String, _
        ByVal uFlags As Long) As Long

Sub PlayTheSound(ByVal WhatSound As String)
    If Dir(WhatSound, vbNormal) = "" Then
        ' WhatSound is not a file. Get the file named by
        ' WhatSound from the Windows\Media directory.
        WhatSound = Environ("SystemRoot") & "\Media\" & WhatSound
        If InStr(1, WhatSound, ".") = 0 Then
            ' if WhatSound does not have a .wav extension,
            ' add one.
            WhatSound = WhatSound & ".wav"
        End If
        If Dir(WhatSound, vbNormal) = vbNullString Then
            Beep            ' Can't find the file. Do a simple Beep.
            Exit Sub
        End If
    Else
        ' WhatSound is a file. Use it.
    End If

    sndPlaySound32 WhatSound, 0&    ' Finally, play the sound.
End Sub

Public Sub OpenLinksMessage(olMail As Outlook.MailItem)

Dim Reg1 As RegExp
Dim AllMatches As MatchCollection
Dim M As Match
Dim strURL As String
Dim RetCode As Long

Set Reg1 = New RegExp

With Reg1
.Pattern = "(https?[:]//([0-9a-z=\?:/\.&-^!#$;_])*)"
.Global = True
.IgnoreCase = True
End With

PlayTheSound "chimes.wav"

' If the regular expression test for URLs in the message body finds one or more
If Reg1.test(olMail.Body) Then

'      Use the RegEx to return all instances that match it to the AllMatches group
       Set AllMatches = Reg1.Execute(olMail.Body)
       For Each M In AllMatches
               strURL = M.SubMatches(0)
'              Don't activate any URLs that are for unsubscribing; skip them
               If InStr(1, strURL, "unsubscribe") Then GoTo NextURL
'              If the URL ends with a > from being enclosed in darts, strip that > off
               If Right(strURL, 1) = ">" Then strURL = Left(strURL, Len(strURL) - 1)
'              The URL to activate to accept must contain both of the substrings in the IF statement
               If InStr(1, strURL, ".com") Then
                     PlayTheSound "TrainWhistle.wav"
'                    Activate that link to accept the job
                     RetCode = ShellExecute(0, "Open", "http://nytimes.com")
                     Set Reg1 = Nothing
                     Exit Sub
               End If

NextURL:
   Next

End If

Set Reg1 = Nothing

End Sub

Private Sub TestLaunchURL()
    Dim currItem As MailItem
    Set currItem = ActiveExplorer.Selection(1)
    OpenLinksMessage currItem
End Sub

如果我通过使用通过调试器运行TestLaunch子例程，或创建一条规则，最后说在收件箱中已有的邮件上运行，它按

If I trigger the above code either by using the TestLaunch subroutine via the debugger, or create a rule and at the end say "Run on messages already in the inbox," it functions perfectly.

我现在唯一不能做的就是在收到新邮件时使用Outlook规则的运行脚本功能来触发此操作。

The only thing I can't do right now is get this to be triggered using the "run script" feature of an Outlook Rule when a new message arrives.

关于如何克服最后障碍的任何理论或帮助将不胜感激。

Any theories or assistance regarding how to get over this last hurdle would be very much appreciated.

推荐答案

这个问题的答案，包括相同的代码，已经由我回答了我提出的后续问题：

The answer to this question, including the code for same, has been answered by me on a follow up question I'd asked: Why does this regular expression test give different results for what should be the same body text?

请参考该线程上的答案以获取解决方案。

Please refer to the answer on that thread for the solution.

这篇关于激活电子邮件中包含的特定URL-进行2的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！