2017-08-13 28 views
0

他のメンバーのアドバイスでこの新しいトピックを作成しています。この時点でどのように到着したかに関する追加の履歴については、this questionを参照してください。Outlook "スクリプトを実行する"ルールが受信メッセージのVBAスクリプトをトリガーしない

私はそれがトリガーます場合、私は作品を知っていることを、このVBAスクリプトを持っています。 TestLaunchサブルーチンを使用して、受信トレイに既にルール基準を満たしているメッセージが表示されている場合(ただし、ルールでは実行されていない)、完全に有効にするリンクを有効にします。ルールを作成して受信トレイ内の既存のすべてのメッセージに適用するとすれば、それは完璧に機能します。ただし、必要な場合は、に新しいメッセージが到着すると、は届きません。その一環として、音は常にメッセージが到着したときに再生する「サウンドを再生」と

Outlook "New Message" rule that has "play sound" enabled

は、私はこのようなルールを持っているのであれば、スクリプトがトリガされていないことを知っています2つの指定された送信者のいずれかから送信されるため、ルールがトリガーされています。私は、ルールからパートを演奏音を除去し、代わりにテスト目的のためにVBAコードにそれを統合している:

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 

VBAスクリプトは、すべての場合にトリガされた場合、「CHIMES.WAV」を再生し、再生すべき」実際のリンクアクティベーション処理が行われる場合は、「TrainWhistle.wav」と入力します。新しいメッセージが到着したときにも、いずれも発生しませんが、このスクリプトを実行するOutlookルールに「再生音」がある場合、そのサウンドは再生されます。

現時点では、テストプロセスの早い段階でselfcert.exeを使用していたOutlookの署名が気になるため、すべてのユーザーにマクロを許可するように設定しています。私は本当にこれがすべて完了したときに "すべてを実行"にするのではなく、マクロ保護を再度昇格させたいと思っています。

しかし、まず、このスクリプトがデバッガ経由で、または既存のメッセージに適用された場合、なぜこのスクリプトが完全に動作するのか理解できませんが、既存のメッセージに適用される同じOutlookルールによってトリガされません。実際の新しいメッセージが到着します。 Outlook 2010では、このスクリプトを開発していますが、Outlook 2016では、展開先の友人のマシンでも同じことが言えます。

この問題を解決するためのガイダンスは、最も高く評価されます。

+0

この質問と以前の質問では、OpenLinksMessageを選択するルールウィザードに「スクリプトを実行する」オプションがあることを認識していない可能性があります。 – niton

+0

ああ、いいえ。私は、これがテキストとタイトルにおけるルールの拡張された議論から完全に明らかではないとは思わなかった。問題は、ルール内の「スクリプトの実行」は、メッセージが実行されるべきルール基準を満たしていても実際にはスクリプトを実行していないことです。 「スクリプトを実行する」というルールのスクリーンショットには入らないようにしましょう。 – britechguy

+0

他の人は、着信メッセージのスクリプトコードを実行しますか?唯一のコード行として、MsgBox oMail.SenderEmailAddressのような単純なもの。すべての着信メッセージに対して実行します。ルールにはアドレス基準はありません。 – niton

答えて

0

最終的に動作するコードは次のとおりです。確かに、olMailの.Bodyメンバーは、何らかの処理の背後に何らかの処理が起きるまで利用できません。長い間待たなければ、それを使ってテストするときにはそこにはありません。パブリックSub OpenLinksMessageに焦点を合わせる

この処理を可能にした主な変更点は、明らかにコード行を追加したことです。Set InspectMail = olMail.GetInspector.CurrentItem。このset文を実行するのにかかる時間は、.BodyがOutlookルールによって渡されたolMailパラメータで使用できるようになります。興味深いのは、set文の後にInspectMail.Bodyをすぐに表示すると、olMail.Bodyのように、空であることが示されます。彼の忍耐と支援のためのniton

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 



Public Sub OpenLinksMessage(olMail As Outlook.MailItem) 

Dim InspectMail As Outlook.MailItem 
Dim Reg1 As RegExp 
Dim AllMatches As MatchCollection 
Dim M As Match 
Dim strURL As String 
Dim SnaggedBody As String 
Dim RetCode As Long 

' The purpose of the following Set statement is strictly to "burn time" so that the .Body member of 
' olMail is available by the time it is needed below. Without this statement the .Body is consistently 
' showing up as empty. What's interesting is if you use MsgBox to display InspectMail.Body immediately after 
' this Set statement it shows as empty. 
Set InspectMail = olMail.GetInspector.CurrentItem 

Set Reg1 = New RegExp 

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

RetCode = Reg1.Test(olMail.Body) 
' If the regular expression test for URLs in the message body finds one or more 
If RetCode 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 
'     Activate that link to accept the job 
        RetCode = ShellExecute(0, "Open", strURL) 
        Set InspectMail = Nothing 
        Set Reg1 = Nothing 
        Set AllMatches = Nothing 
        Set M = Nothing 
        Exit Sub 
       End If 

NextURL: 
    Next 

End If 

Set InspectMail = Nothing 
Set Reg1 = Nothing 
Set AllMatches = Nothing 
Set M = Nothing 

End Sub 

感謝します。

関連する問題