[Webinar] Learn how to a build a cloud-first strategyRegister Now

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 263
  • Last Modified:

Need script rule in Outlook using Visual Basic for Applications

All of my emails coming into Outlook are being marked SPAM-HIGH: or SPAM-MED: ect...  In the rules wizard for Outlook there is an option to run a script for the rule - Can anyone help write a script for Outlook that would remove the text "SPAM-MED:" from the subject line before delivering?  The help section says it must be written in Microsoft Visual Basic for Applications, not VBScript - Any help is appreciated
0
Bethanzil
Asked:
Bethanzil
  • 21
  • 5
1 Solution
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Stand By....
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
What version of Outlook are you using?
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Try this:

Place this in a new macro called "ItemSend" (note, this will affect EVERY email you sned)



Private Sub Application_ItemSend(ByVal Item As Object, _
                                       Cancel As Boolean)
  dim cToken() as string   
  dim nToken as integer
  dim BSpammer as integer
  dim cSpammer() as string
  xSpammer = array("SPAM-HIGH","SPAM-MED:")
  cToken = split(Item.subject," ")
  for nToken = 0 to ubBound(cToken)
    for nSpammer = 0 to UBound(cSpammer)
       if instr(cToken(nToken), cSpammer(nSpammer)) > 0 then
          cToken(nTone) = ""
       endif
    next
 next
 for nToken = 0 to uBound(cToken)
    Item.Subject = Item.Subject+ cToken(nToken)+ " "
 next
End Sub

Open in new window

0
Configuration Guide and Best Practices

Read the guide to learn how to orchestrate Data ONTAP, create application-consistent backups and enable fast recovery from NetApp storage snapshots. Version 9.5 also contains performance and scalability enhancements to meet the needs of the largest enterprise environments.

 
Chris Raisin(Retired Analyst/Programmer)Commented:
Hang 5...I need to test this agin...something is not quite right.....standy by
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
OK...I forgot to put the code in the module "thisOutLookSession".

After doing that it worked.

Also there were a couple of typo-errors in the code which have now beed fixed.

Remember that the code must go in the module "thisOutlookSession"

Seems to work fine. What it does is take any of the words you store in the array within the code and removes them if found in the title of any email being sent out.
It is NOT case sensitive, so it will remove both " spam-med:" and "SPAM-MED:"

Hope this is what you were after.

Cheers
Chris
(craisin)


Private Sub Application_ItemSend(ByVal Item As Object, _
                                       Cancel As Boolean)
  Dim cToken() As String
  Dim nToken As Integer
  Dim nWord As Integer
  Dim cWordsToRemove() As Variant

  'define the words to be removed
  cWordsToRemove = Array("SPAM-HIGH", "SPAM-MED:")
  
  'Go through the subject and store each word to an array
  cToken = Split(Item.Subject, " ")

  'Now scan the stored words in the array and remove any that are
  'not to be stored by setting the value stored back to a null string
  For nToken = 0 To UBound(cToken)
    For nWord = 0 To UBound(cWordsToRemove)
       If InStr(UCase(cToken(nToken)), cWordsToRemove(nWord)) > 0 Then
         'the word is found so set it back to a null string 
          cToken(nToken) = ""
       End If
    Next
 Next
'Initialize the emails subject to a null string
 Item.Subject = ""
'Now rejoin all the accepted words in the Subject back together 
'and store in the "Subject" property.
 For nToken = 0 To UBound(cToken)
    Item.Subject = Item.Subject + cToken(nToken) + " "
 Next
End Sub

Open in new window

0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
If you prefer not to have it stored in Outlook's code (so it always runs even if not showing as a rule). you could change the code slightly as follows, then store it as code to run within your rules.
Private Sub RemoveWords()

  dim oItem as object
  Dim cToken() As String
  Dim nToken As Integer
  Dim nWord As Integer
  Dim cWordsToRemove() As Variant

  'obtain pointer to current email message
  Set oItem = Application.ActiveInspector.CurrentItem
  
  'define the words to be removed
  cWordsToRemove = Array("SPAM-HIGH", "SPAM-MED:")
  
  'Go through the subject and store each word to an array
  cToken = Split(oItem.Subject, " ")

  'Now scan the stored words in the array and remove any that are
  'not to be stored by setting the value stored back to a null string
  For nToken = 0 To UBound(cToken)
    For nWord = 0 To UBound(cWordsToRemove)
       If InStr(UCase(cToken(nToken)), cWordsToRemove(nWord)) > 0 Then
         'the word is found so set it back to a null string 
          cToken(nToken) = ""
       End If
    Next
 Next
'Initialize the emails subject to a null string
 oItem.Subject = ""
'Now rejoin all the accepted words in the Subject back together 
'and store in the "Subject" property.
 For nToken = 0 To UBound(cToken)
    oItem.Subject = oItem.Subject + cToken(nToken) + " "
 Next
End Sub

Open in new window

0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
In my Outlook I cannot see where you can get a spefic piece of code to run under "Rules" so I could not test the last bit of code, but it certainly works in the "applied to all emails" module "thisOutlookSession".

Please advise me how you intent to insert a rule that runs the code.

Cheers
Chris
(craisin)
0
 
BethanzilAuthor Commented:
Hi!
I'm using Outlook 2010 - I'm going to test this momentarily - will it work for incoming email also?  All of my incoming emails are the ones that are marked -
0
 
BethanzilAuthor Commented:
When you create the rule in Outlook - you put the description in > after that is asks what you want to do with it and there is a check box for "run a script" where you can put your code in.  Thank you so much!!! I can't wait to try and see if this works.
 
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
There is a great article on putting code in "thisOutlookSession" and it demonstrates the power of scripting in Outlook:

   http://msdn.microsoft.com/en-us/library/aa155701(office.10).aspx

To check on each email as it arrives place the same code in a subroutine inside
"thisOutlookSession" as showing below (same code, just a different subroutine name). I suppose you could adjust it to be code that runs under a rule, just place it in your normal macros but call it "RemoveWords" (in other words the same code as listed before)

Please note: In all this code, the array created of the words in the subject assume there is a space between the words. If your email says something like:
SPAM-HIGH:This is a virus warning!" (note no space between the colon and the next word) then it will not work properly. Since this may happen, I have changed the code slightly to allow for this possibility), See Version 2 below.



Private Sub Application_NewMail()
  Dim cToken() As String
  Dim nToken As Integer
  Dim nWord As Integer
  Dim cWordsToRemove() As Variant

  'define the words to be removed
  cWordsToRemove = Array("SPAM-HIGH", "SPAM-MED:")
  
  'Go through the subject and store each word to an array
  cToken = Split(Item.Subject, " ")

  'Now scan the stored words in the array and remove any that are
  'not to be stored by setting the value stored back to a null string
  For nToken = 0 To UBound(cToken)
    For nWord = 0 To UBound(cWordsToRemove)
       If InStr(UCase(cToken(nToken)), cWordsToRemove(nWord)) > 0 Then
         'the word is found so set it back to a null string 
          cToken(nToken) = ""
       End If
    Next
 Next
'Initialize the emails subject to a null string
 Item.Subject = ""
'Now rejoin all the accepted words in the Subject back together 
'and store in the "Subject" property.
 For nToken = 0 To UBound(cToken)
    Item.Subject = Item.Subject + cToken(nToken) + " "
 Next
End Sub

Open in new window

0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Version 2 takes into account both upper and lowercase, but it will not pick up mixed case withion the subject line, so "Spam-High" would sneak through.
So I have included a scan for UPPER, then LOWER, then jsut as showing in the array. Fir that reason placing in the array the values as Upper and Lowercase will also check for that:

   e.g.
'Version 2:

Private Sub RemoveWords()

  dim oItem as object
  Dim cToken() As String
  Dim nToken As Integer
  Dim nWord As Integer
  Dim cWordsToRemove() As Variant

  'obtain pointer to current email message
  Set oItem = Application.ActiveInspector.CurrentItem
  
  'define the words to be removed
  cWordsToRemove = Array("SPAM-HIGH", "SPAM-MED:")
  
  'Go through the subject and store each word to an array
  cToken = Split(oItem.Subject, " ")

  'Now scan the stored words in the array and remove any that are
  'not to be stored by setting the value stored back to a null string
  For nToken = 0 To UBound(cToken)
    For nWord = 0 To UBound(cWordsToRemove)
       'see if the words to be eliminate are found anywhere
       'in the title
       If InStr(UCase(cToken(nToken)), _
                      UCase(cWordsToRemove(nWord))) > 0 Then
         'the word is found so set it back to a null string 
         'scan for the word in lower-case 
         cToken(nToken) = Replace(cToken(nToken), _
                                  LCase(cWordsToRemove(nWord)), _
                                  "", , vbTextCompare)
         'Scan for the array word in Upper-case
         cToken(nToken) = Replace(cToken(nToken), _
                                  UCase(cWordsToRemove(nWord)), _
                                  "", , vbTextCompare)
         'scan for word exactly as showing in the array
         cToken(nToken) = Replace(cToken(nToken), _
                                  cWordsToRemove(nWord), _
                                  "", , vbTextCompare)
       End If
    Next
 Next
'Initialize the emails subject to a null string
 oItem.Subject = ""
'Now rejoin all the accepted words in the Subject back together 
'and store in the "Subject" property.
 For nToken = 0 To UBound(cToken)
    oItem.Subject = oItem.Subject + cToken(nToken) + " "
 Next
End Sub

Open in new window

0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Version 3 is a final simpligification showing a straight "Replace" on the title.
This is probably the best approach, rather than having to worry about each indicidual word in the title, looking it as a whole. (Notice the upper and lower case in the defining of the words in the array).

I think you should go with Version 3 for its simplicity, either as a call to "ReplaceWords" through "Rules" or directly in the "thisOutlookSession"
module for direct action each time an item is sent or received.

Cheers
Chris
(craisin)
'Version 3:

Private Sub RemoveWords()

  dim oItem as object

  Dim nWord As Integer
  Dim cWordsToRemove() As Variant

  'obtain pointer to current email message
  Set oItem = Application.ActiveInspector.CurrentItem
  
  'define the words to be removed
  cWordsToRemove = Array("Spam-High", "Spam-Med:")
  
  For nWord = 0 To UBound(cWordsToRemove)
    'see if the words to be eliminate are found anywhere
    'in the title
    If InStr(UCase(oItem.Subject), _
                   UCase(cWordsToRemove(nWord))) > 0 Then
      'the word is found so set it back to a null string 
      'scan for the word in lower-case 
      oItem.Subject = Replace(oItem.Subject, _
                              LCase(cWordsToRemove(nWord)), _
                              "", , vbTextCompare)
      'Scan for the array word in Upper-case
      oItem.Subject = Replace(oItem.Subject, _
                              UCase(cWordsToRemove(nWord)), _
                              "", , vbTextCompare)
      'scan for word exactly as showing in the array
      oItem.Subject = Replace(oItem.Subject, _
                              cWordsToRemove(nWord), _
                              "", , vbTextCompare)
    End If
  Next
End Sub

Open in new window

0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
That is strange, when I click on :run a script" I do not get the names of any scripts to run. Where do you record your scripts? I have everything written in my VBA Editor (under macros).
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
A final thought, you could also place the name of the script "RemoveWords"
in each of the procedures which handle "Receive and Send" within your
"thisOutlookSession" module as shopwing below. Just make sure that "RemoveWords" is defined as "Public" and not "Private" in its first line as follows:

         Public Sub RemoveWords()

Lots of variations!    :-)

Cheers
Chris
Private Sub Application_ItemSend(ByVal Item As Object, _
                                       Cancel As Boolean)
   RemoveWords
End Sub

Private Sub Application_NewMail()
   RemoveWords
End Sub

Open in new window

0
 
BethanzilAuthor Commented:
I must be missing something - I added to the "thisOutllokSession" module (Version 3) but it isn't working - any suggestions as to what I missed?  I am getting the same thing with the ability to run scripts from the rules - I tried saving as a macro and it doesn't show up as an option -
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
I cannot see where it says "run a macro" under Rules.

From the "Home" Tab I click on "Manage Rules and Alerts" then:
       1. Click on "New Rule"
       2. Select "Apply Rule on message I receive"
       3. Click on "Next" button
       4. Don't select any condition, and click "Next" button again
       5. Answer "Yes" to the question if I want the rule applied to every message
 
Now I cannot see where to run a macro. If I choose run a "script" there is from which to select, and this is also the case if I select "perform a custom action".

Can you give me step by step procedure to get to the spot where I can select "run a macro"?

can you also list the entire code you have in your module "thisOutlookSession" since code in this module must run every time you "Send" or "receive" email within Outlook, and I cannot see at the moment why yours is not running.

Just confirming, I am using Outlook Office Professional Plus 2010
Version 14.0.6106.5005 (32 bit)

Cheers
Chris
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Any response to my last comment?
0
 
BethanzilAuthor Commented:
Hi Chris,
Sorry - last week was a blur...
Ok - so for the rule...  If I click on Rules > Create Rule > Click box for "Subject Contains" and I enter the text SPAM-HIGH: > Then click on Advanced Options > I had to unclick the next condition box as it contained the whole subject > Apply rule after message arrives > clicked next > in the next dialog box there is an option for the action "run a script" > it puts some text in the rule description box where you can click on the link to select a script.  

I cannot see any scripts to choose from though - I'm not sure where they are supposed to be saved.

In my ThisOutlookSession I entered the following code from your message above (version 3)

Private Sub RemoveWords()

  dim oItem as object

  Dim nWord As Integer
  Dim cWordsToRemove() As Variant

  'obtain pointer to current email message
  Set oItem = Application.ActiveInspector.CurrentItem
 
  'define the words to be removed
  cWordsToRemove = Array("Spam-High", "Spam-Med:")
 
  For nWord = 0 To UBound(cWordsToRemove)
    'see if the words to be eliminate are found anywhere
    'in the title
    If InStr(UCase(oItem.Subject), _
                   UCase(cWordsToRemove(nWord))) > 0 Then
      'the word is found so set it back to a null string
      'scan for the word in lower-case
      oItem.Subject = Replace(oItem.Subject, _
                              LCase(cWordsToRemove(nWord)), _
                              "", , vbTextCompare)
      'Scan for the array word in Upper-case
      oItem.Subject = Replace(oItem.Subject, _
                              UCase(cWordsToRemove(nWord)), _
                              "", , vbTextCompare)
      'scan for word exactly as showing in the array
      oItem.Subject = Replace(oItem.Subject, _
                              cWordsToRemove(nWord), _
                              "", , vbTextCompare)
    End If
  Next
End Sub

I also tried creating a macro with the same code and running the macro - when I click run, it gives me the following error - Run-time error "91"  Object variable or With block variable not set.

Liz


0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
On what line does that error occur, Liz?

Chers
Chris
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
On which menu do you access "Rules"? I've lost mine and am having trouble finding where I should set them up again. I have set them up on the "Send/Receive" ribbon, but I am not sure where you normally have "Rules" showing.

I would prefer to have them where everyone else does (helps with answering questions).

Please advise.

Cheers
Chris
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
For documentation and clarification on setting up scripts in Outlook 2010
so they appear under "Rules" the following might help.

http://support.microsoft.com/kb/306108

Cheers
Chris
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
And even better is the link contained in the one above!

http://www.outlookcode.com/article.aspx?id=62

Cheers
Chris
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Liz,

Do you have answers to my question under items 36990082 and 36090180?

Cheers
Chris
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
By the way,

I am so sorry about the delay.

My oldest sister, Karen, died 3 weeks ago after contracting "Golden Staph".
It was a great shock snce she was only 57 and we think she contracted it
while at a dental appointment where she had an infected molar.

I have only just now returned after her funeral last week.

I look forward to your repsonse to my questions.

Cheers
Chris



0
 
BethanzilAuthor Commented:
Thank you for your help!
0
 
Chris Raisin(Retired Analyst/Programmer)Commented:
Liz,

For the benefit of others, can you please indicate whether you arrived at the correct solution to your question,and what that solution was?

You had notanswered my questions and so I cannot ascertain exactly what was the solution. Was it the "ItemSend" code I gave at the start of the question/answer flow (36910170 or 36910220)? Also there were questions about incoporation into "Rules".

Whta worked out correct for you?

Thanks for the points - appreciated.

Cheers
Chris
0

Featured Post

Industry Leaders: We Want Your Opinion!

We value your feedback.

Take our survey and automatically be enter to win anyone of the following:
Yeti Cooler, Amazon eGift Card, and Movie eGift Card!

  • 21
  • 5
Tackle projects and never again get stuck behind a technical roadblock.
Join Now