Link to home
Start Free TrialLog in
Avatar of Jegajothy vythilingam
Jegajothy vythilingamFlag for United States of America

asked on

Outlook 2007 - macro

How do I record a Macro in Outlook 2007.  What I want to do is when I am in the Junk email folder, and an email is highlighted, it will click on the actiions,  then Junk email, and then Add to List of Blocked Sender List,click Ok, and then select the next email and loop until the last email.
My OS is windows 7. thank u.
Avatar of Chris Bottomley
Chris Bottomley
Flag of United Kingdom of Great Britain and Northern Ireland image

You cannot actually record macros in outlook so we will need to code something for you.
How do you want the email triggered ... button or context menu for example?

Chris
Quite apart from from how to call a macro ... I have just been doing some research and so  far it seems to be that you cannot access the blocked sender list using VBA.

I'm still thinking but perhaps someone will have a more educated awareness of how it could be done.

Chris
Avatar of Jegajothy vythilingam

ASKER

in reply to Chris's first response, I would prefer a button to trigger it. thank u
I have had a go at controlling buttons directly but have not had any luck ... it looks as though you can't do that is gaining ground ... so give it a few days and if you hear nothing more try requesting moderator help to get some more attention to the question.

Basically the interface does not appear to support access to the blocked sender list and I am against sendkeys even if it would work as it can do unwanted actions depending on what happens with the focus/

Chris
In response to Chris, hope u were able to code the macro for me. As i am in and out of so many internet forums or sites, thus it looks like my email is being traded around.  thank  u
Nope no luck else I would have posted ... but appreciate you giving me the opportunity all the same.  I stand by that earlier statement that you cannot do that at all.

I also still suggest you request further attention as it is possible someone else knows of a workaround.

Chris
jegajothy: Is my understanding correct? At a click of a button, you want to loop through all the emails in the junk folder and add then to Blocked Sender List?

Sid

Also see this link. Not sure if this is what you want?

Sid
Sid

Since I didn't think the blocked list is exposed I am interested in your proposal ... so which link ;o)

Chris
Oops where is the link I pasted? I will have to look for it again :(

Sid
Chris, the blocked sender list is stored in a unicode format in the following registry key.

"HKEY_CURRENT_USER\Software\Microsoft\Windows
NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\0a0d020000000000c000000000000046\001f0419a"

001f0419a is for Blocked senders list
001f0418 is for Safe senders list

To test it. Simply add an email to the block sender list and then navigate to the key above and then double click on the key. A normal view can show you the new email address added to that list.

BTW I am still looking for the link that I posted. That link took a different approach then what I have mentioned above.

Sid
Sorry that is 001f041a and not 001f0419a

Still trying to find that link.

Sid
In response to Sid who wrote the following :
SiddharthRout:
jegajothy: Is my understanding correct? At a click of a button, you want to loop through all the emails in the junk folder and add then to Blocked Sender List?

Yes, this is what I am trying to do.  U will not believe the amount of junk mail I receive everyday.  I realize that whenever I open Outlook my email will be slow since it has to check the blocked list.  Not to worry because whenever I get up, I open Outlook and hit the Send/Receive button, and then go and do my bathroom routine and then breakfast and return to my pc which takes about an hour. So I can wait. Thank u.
Hi, guys.

Chris is quite correct when he says that the Blocked Senders list isn't exposed for programming purposes.  This means that the only solution is to simulate clicking buttons in the interface.  The macro below is an example of how to do this.  It will add the sender of the currently selected message to the Blocked Senders List.  This allows us to reduce the number of clicks required to block an address to one.  

Handling multiple items is a problem.  Outlook's GUI doesn't allowing blocking multiple items as once, so it's no surprise that we can't do it via code  either.  To further complicate matters Outlook's programming model doesn't have any method of changing the items selected in the GUI other than SendKeys.  As Chris already noted, SendKeys is a kludge that should be avoided as much as possible.

There's also very little point to the Blocked Senders List.  Spammers change their addresses all the time, so the address you block today won't be  the same address the spam is coming from tomorrow.


Sub JunkSender()
    Dim ofcMenu As Object, ofcActionsMenu As Object, ofcJunkMenu As Object, ofcBlockSenderButton As Object
    Set ofcMenu = Application.ActiveExplorer.CommandBars.Item("Menu Bar")
    Set ofcActionsMenu = ofcMenu.Controls.Item("Actions")
    Set ofcJunkMenu = ofcActionsMenu.Controls.Item("Junk E-mail")
    Set ofcBlockSenderButton = ofcJunkMenu.Controls.Item("Add Sender to Blocked Senders List")
    ofcBlockSenderButton.Execute
    Set ofcMenu = Nothing
    Set ofcActionsMenu = Nothing
    Set ofcJunkMenu = Nothing
    Set ofcBlockSenderButton = Nothing
End Sub

Open in new window

jegajothy: Please do not close this question. I am working on a solution for you and I am real close.

Sid
Update!!!!!

Done Tested and Tried :)

Give me few moments to clean up the code and document it.

Sid
ASKER CERTIFIED SOLUTION
Avatar of SiddharthRout
SiddharthRout
Flag of India image

Link to home
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
Start Free Trial
I crown u as Super Guru, congratulations.
Glad to be help ;)

Sid
In trying SiddharthRout's code, I got a compile error, that string2hex was not defined.  
It was at owShell.Regwrite etc etc
I have no clue on how to fix this.  Hope u can help. thank u.
Oops I missed this code...

Add this to the end of the above code.

Public Function string2hex(s) As String
    Dim r As String
    j = Len(s) + 1
    i = 1
    While (i < j)
        If Mid(s, i, 1) = "~" Then
            r = r & "0A"
        Else
            r = r & Hex(Asc(Mid(s, i, 1)))
        End If
        i = i + 1
    Wend
    string2hex = r
End Function

Open in new window


Sid
The code as posted doesn't work for me.  First, it appears that the function String2Hex is missing.  I get an immediate compile error when I run it.  Second, the Exit Sub at line #48 looks like it will cause the code to halt at that point without finishing.
Nice to see that EE hadn't refreshed.  Ignore my first issue since I see you added the code.
With that code added and with line #48 commented out I now get a type mismatch at line #94.
UPDATED CODE

@BlueDevilFan: I forgot to remove that "Exit sub" I had put it for testing something and forgot to remove it.

'~~> VBA Code to loop through Junk Items and get all the email addresses
'~~> and add them to block sender list
Sub Sample()
    Dim objMapiName As Outlook.NameSpace
    Dim NewEmailBlockList() As String, OldEmailBlockList() As String
    Dim EmailList() As String, MergeOldNewBlockList() As String
    Dim junkRegValue As String, ListToHex As String
    Dim tempEmailBlockList As Variant
    Dim owShell As Object
    Dim EmailExists As Boolean
    Dim i As Long, j As Long, k As Long
    
    Set objMapiName = Application.GetNamespace("MAPI")
    Set vFolder = objMapiName.GetDefaultFolder(olFolderJunk)
    
    '~~> Store the email addresses from Junk Folder in an array
    '~~> I can add the items ditrectly to OldEmailBlockList() but have
    '~~> delibrately kept it for understanding purpose
    For i = 1 To vFolder.Items.Count
        Set myitem = vFolder.Items.Item(i)
        ReDim Preserve EmailList(i - 1)
        EmailList(i - 1) = myitem.SenderEmailAddress
    Next i
    
    '~~> This part of code is courtesy http://www.pcreview.co.uk
    '~~> START BLOCK www.pcreview.co.uk Code
    Set owShell = CreateObject("WScript.Shell")
    tempEmailBlockList = ""
    junkRegValue = "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\0a0d020000000000c000000000000046\001f041a"

    tempEmailBlockList = owShell.RegRead(junkRegValue)
    
    If UBound(tempEmailBlockList) <> 0 Then
        For i = LBound(tempEmailBlockList) To UBound(tempEmailBlockList)
            Debug.Print tempEmailBlockList(i)
            If Hex(tempEmailBlockList(i)) <> 0 Then
                strJunkMailList = strJunkMailList & Chr(tempEmailBlockList(i))
            Else
                strJunkMailList = strJunkMailList & " "
            End If
            
            On Error Resume Next
            strJunkMailList = Left(strJunkMailList, InStr(1, strJunkMailList, " ") - 1)
            On Error GoTo 0
            strJunkMailList = Replace(strJunkMailList, " ", "")
        Next
    End If
    
    '~~> This gives the list in the registry
    'Debug.Print strJunkMailList
    
    OldEmailBlockList = Split(strJunkMailList, ";")
    '~~> END BLOCK www.pcreview.co.uk Code
    
    k = 0
    
    '~~> Merge emaillist() and OldEmailBlockList()
    For j = LBound(OldEmailBlockList) To UBound(OldEmailBlockList) - 1
        ReDim Preserve MergeOldNewBlockList(k)
        MergeOldNewBlockList(k) = OldEmailBlockList(j)
        k = k + 1
    Next j
    For i = LBound(EmailList) To UBound(EmailList)
        For j = LBound(OldEmailBlockList) To UBound(OldEmailBlockList)
            If EmailList(i) = OldEmailBlockList(j) Then
                EmailExists = True
                Exit For
            Else
                EmailExists = False
            End If
        Next j
        If EmailExists = False Then
            ReDim Preserve MergeOldNewBlockList(k)
            MergeOldNewBlockList(k) = EmailList(i)
        End If
        k = k + 1
    Next i
    
    '~~> New list that needs to be added to registry
    For i = LBound(MergeOldNewBlockList) To UBound(MergeOldNewBlockList)
        If Len(Trim(MergeOldNewBlockList(i))) <> 0 Then
            If Len(Trim(ListToHex)) = 0 Then
                ListToHex = MergeOldNewBlockList(i)
            Else
                ListToHex = ListToHex & ";" & MergeOldNewBlockList(i)
            End If
        End If
    Next
    
    '~~> This gives the New list for registry
    'Debug.Print ListToHex
    
    '~~> Update reg key after converting it to respective format
    owShell.Regwrite junkRegValue, LongToBinary(CLng(string2hex(ListToHex))), "REG_BINARY"
End Sub

'~~> This piece of code taken from http://www.vb-helper.com/howto_binary_to_text.html
Function LongToBinary(ByVal long_value As Long, Optional ByVal separate_bytes As Boolean = True) As String
    Dim hex_string As String, nibble_string As String, result_string As String
    Dim digit_num As Integer, digit_value As Integer, factor As Integer, bit As Integer

    '~~> Convert into hex.
    hex_string = Hex$(long_value)

    '~~> Zero-pad to a full 8 characters.
    hex_string = Right$(String$(8, "0") & hex_string, 8)

    '~~> Read the hexadecimal digits
    '~~> one at a time from right to left.
    For digit_num = 8 To 1 Step -1
        '~~> Convert this hexadecimal digit into a
        '~~> binary nibble.
        digit_value = CLng("&H" & Mid$(hex_string, digit_num, 1))

        '~~> Convert the value into bits.
        factor = 1
        nibble_string = ""
        For bit = 3 To 0 Step -1
            If digit_value And factor Then
                nibble_string = "1" & nibble_string
            Else
                nibble_string = "0" & nibble_string
            End If
            factor = factor * 2
        Next bit

        '~~> Add the nibble's string to the left of the
        '~~> result string.
        result_string = nibble_string & result_string
    Next digit_num

    '~~> Add spaces between bytes if desired.
    If separate_bytes Then
        result_string = _
            Mid$(result_string, 1, 8) & " " & _
            Mid$(result_string, 9, 8) & " " & _
            Mid$(result_string, 17, 8) & " " & _
            Mid$(result_string, 25, 8)
    End If

    '~~> Return the result.
    LongToBinary = result_string
End Function

Public Function string2hex(s) As String
    Dim r As String
    j = Len(s) + 1
    i = 1
    While (i < j)
        If Mid(s, i, 1) = "~" Then
            r = r & "0A"
        Else
            r = r & Hex(Asc(Mid(s, i, 1)))
        End If
        i = i + 1
    Wend
    string2hex = r
End Function

Open in new window

>>>With that code added and with line #48 commented out I now get a type mismatch at line #94.

Hmmm. Let me recheck it.

Sid
The lone value in the pre-existing blocked list is also being duplicated.
BlueDevilFan: What is the value that you are getting if you type these 3 lines in Line 89

    Debug.Print strJunkMailList
    Debug.Print ListToHex
    Exit Sub

Sid
Ok I have tested the code. It is working fine till it reaches

CLng(string2hex(ListToHex))

string2hex(ListToHex) is giving the expected result when I compare it with

string2hex(strJunkMailList)

So it is now getting stuck in converting string to long.

Let me see while commenting the code what did I delete by mistake as it was working just fine when I tested it.

Sid
This is what I get from those two statements.

zales@e.zales.com;
zales@e.zales.com;Fool@foolmail.com

One of the entries had been duplicated, but that appears to have been my fault.  I still get the type mismatch.
To SiddharthRout and BlueDevilFan, hope u would give me the final fix of the code, as i am just a novice in this.
jegajothy: I am already working on it :)

Sid
BlueDevilfan: Could you test this for me. If it works then I will comment the code. And thanks for staying with me on this.

I took a totally different approach.

'~~> VBA Code to loop through Junk Items and get all the email addresses
'~~> and add them to block sender list

Const st_TEMPFILE = "C:\Temp\TEMP.REG"

Sub Sample()
    Dim objMapiName As Outlook.NameSpace
    Dim NewEmailBlockList() As String, OldEmailBlockList() As String
    Dim EmailList() As String, MergeOldNewBlockList() As String
    Dim junkRegValue As String, ListToHex As String, regky As String
    Dim tempEmailBlockList As Variant
    Dim owShell As Object
    Dim EmailExists As Boolean
    Dim i As Long, j As Long, k As Long
    Dim MyArray() As Long
    
    Set objMapiName = Application.GetNamespace("MAPI")
    Set vFolder = objMapiName.GetDefaultFolder(olFolderJunk)
    
    '~~> Store the email addresses from Junk Folder in an array
    '~~> I can add the items ditrectly to OldEmailBlockList() but have
    '~~> delibrately kept it for understanding purpose
    For i = 1 To vFolder.Items.Count
        Set myitem = vFolder.Items.item(i)
        ReDim Preserve EmailList(i - 1)
        EmailList(i - 1) = myitem.SenderEmailAddress
    Next i
    
    '~~> This part of code is courtesy http://www.pcreview.co.uk
    '~~> START BLOCK www.pcreview.co.uk Code
    Set owShell = CreateObject("WScript.Shell")
    tempEmailBlockList = ""
    junkRegValue = "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\0a0d020000000000c000000000000046\001f041a"
    
    tempEmailBlockList = owShell.RegRead(junkRegValue)
    
    If UBound(tempEmailBlockList) <> 0 Then
        For i = LBound(tempEmailBlockList) To UBound(tempEmailBlockList)
            If Hex(tempEmailBlockList(i)) <> 0 Then
                strJunkMailList = strJunkMailList & Chr(tempEmailBlockList(i))
            Else
                strJunkMailList = strJunkMailList & " "
            End If
            
            On Error Resume Next
            strJunkMailList = Left(strJunkMailList, InStr(1, strJunkMailList, " ") - 1)
            On Error GoTo 0
            strJunkMailList = Replace(strJunkMailList, " ", "")
        Next
    End If
    '~~> This gives the list in the registry
    'Debug.Print strJunkMailList
    
    OldEmailBlockList = Split(strJunkMailList, ";")
    '~~> END BLOCK www.pcreview.co.uk Code
    
    k = 0
    
    '~~> Merge emaillist() and OldEmailBlockList()
    For j = LBound(OldEmailBlockList) To UBound(OldEmailBlockList) - 1
        ReDim Preserve MergeOldNewBlockList(k)
        MergeOldNewBlockList(k) = OldEmailBlockList(j)
        k = k + 1
    Next j
    For i = LBound(EmailList) To UBound(EmailList)
        For j = LBound(OldEmailBlockList) To UBound(OldEmailBlockList)
            If EmailList(i) = OldEmailBlockList(j) Then
                EmailExists = True
                Exit For
            Else
                EmailExists = False
            End If
        Next j
        If EmailExists = False Then
            ReDim Preserve MergeOldNewBlockList(k)
            MergeOldNewBlockList(k) = EmailList(i)
        End If
        k = k + 1
    Next i
    
    '~~> New list that needs to be added to registry
    For i = LBound(MergeOldNewBlockList) To UBound(MergeOldNewBlockList)
        If Len(Trim(MergeOldNewBlockList(i))) <> 0 Then
            If Len(Trim(ListToHex)) = 0 Then
                ListToHex = MergeOldNewBlockList(i)
            Else
                ListToHex = ListToHex & ";" & MergeOldNewBlockList(i)
            End If
        End If
    Next
    
    
    ReDim MyArray(1 To (Len(string2hex(strJunkMailList)) * 2) + 3)
    
    j = 1
    For i = 1 To Len(string2hex(strJunkMailList))
        MyArray(j) = Val(Mid(string2hex(strJunkMailList), i, 2)) + 36
        MyArray(j + 1) = 0
        j = j + 2
    Next i
    MyArray(j) = 0
    MyArray(j + 1) = 0
   
    '~~> Update reg key after converting it to respective format
    regky = "HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\0a0d020000000000c000000000000046"
    RegBinWrite regky, "001f041a", stRegBinary(MyArray)
    MsgBox "DONE"
End Sub

Sub RegBinWrite(key, value, data)
Dim oFS
Dim txtStream
Dim WshShell
Dim valString

key = "[" & key & "]"

If value <> "@" Then
value = Chr(34) & value & Chr(34)
End If

valString = value & "=" & data

Set oFS = CreateObject("Scripting.FileSystemObject")
Set txtStream = oFS.CreateTextFile(st_TEMPFILE, True)
txtStream.WriteLine ("REGEDIT4")
txtStream.WriteLine (key)
txtStream.WriteLine (valString)
txtStream.Close

Set WshShell = CreateObject("Wscript.Shell")
WshShell.Run "regedit /s " & st_TEMPFILE, 1, True
Set WshShell = Nothing

oFS.DeleteFile st_TEMPFILE
Set oFS = Nothing

End Sub

Function stRegBinary(RegBinaryArray)

Dim item, st

If Not IsArray(RegBinaryArray) Then

stRegBinary = ""

Else
For Each item In RegBinaryArray
st = st & CStr(Right("00" & Hex(item), 2)) & " "
Next
stRegBinary = Trim(st)
End If

End Function

Public Function string2hex(s) As String
    Dim r As String
    j = Len(s) + 1
    i = 1
    While (i < j)
        If Mid(s, i, 1) = "~" Then
            r = r & "0A"
        Else
            r = r & Hex(Asc(Mid(s, i, 1)))
        End If
        i = i + 1
    Wend
    string2hex = r
End Function

Open in new window


Sid
jegajothy: Besides the above code I just realized an easier way to achieve what you want.

Use this code to create a block sender list as a text file and then From Outlook, Click on Menu~~>Tools~~>Options.
On the Preferences tab, under E-mail, click Junk E-mail~~>Blocked Senders tab.

Click "Import From File" and click Ok after you select the latest created file.

Sid

Code Used

Const st_TEMPFILE As String = "C:\MyBlockList.txt"

Sub MyBlockList()
    Dim objMapiName As Outlook.NameSpace
    Dim vFolder As Object, myitem As Object
    Dim i As Long
    Dim oFS, txtStream, WshShell
    
    Set objMapiName = Application.GetNamespace("MAPI")
    Set vFolder = objMapiName.GetDefaultFolder(olFolderJunk)
    
    '~~> Check if the junk folder has items
    If vFolder.Items.Count = 0 Then
        MsgBox "No items found in Junk Mail"
        Exit Sub
    End If
    
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set txtStream = oFS.CreateTextFile(st_TEMPFILE, True)
    
    '~~> Store the email addresses from Junk Folder in an array
    For i = 1 To vFolder.Items.Count
        Set myitem = vFolder.Items.item(i)
        txtStream.WriteLine (myitem.SenderEmailAddress)
    Next i
    
    txtStream.Close

    Set WshShell = CreateObject("Wscript.Shell")
    Set WshShell = Nothing

    Set oFS = Nothing
    
    MsgBox "File Created"
End Sub

Open in new window

U are really a genius and it is apparent programming is in your blood stream.  Congratulations and well done for the code.  It works.  By comment, it also looked at the Junk Mail folders in all email accounts.  This will work also for me.  Attached is the txt file for your information.
Thank u once again for a job well done.  MyBlockList.txt
Glad to  be of help :) Sorry about the earlier goof up. I had messed up the code while commenting it.

Sid