Solved

Outlook 2007 - macro

Posted on 2011-02-27
38
624 Views
Last Modified: 2012-05-11
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.
0
Comment
Question by:jegajothy
  • 18
  • 7
  • 6
  • +1
38 Comments
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34992249
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
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34992333
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
0
 

Author Comment

by:jegajothy
ID: 34997599
in reply to Chris's first response, I would prefer a button to trigger it. thank u
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35010222
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
0
 

Author Comment

by:jegajothy
ID: 35137381
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
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35137506
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
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35153812
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

0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35153946
Also see this link. Not sure if this is what you want?

Sid
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 35155191
Sid

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

Chris
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35155208
Oops where is the link I pasted? I will have to look for it again :(

Sid
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35155287
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
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35155471
Sorry that is 001f041a and not 001f0419a

Still trying to find that link.

Sid
0
 

Author Comment

by:jegajothy
ID: 35155550
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.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35155557
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

0
 
LVL 30

Expert Comment

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

Sid
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35156536
Update!!!!!

Done Tested and Tried :)

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

Sid
0
 
LVL 30

Accepted Solution

by:
SiddharthRout earned 500 total points
ID: 35156621
OK... Phew!

Before you run this code, Please manually once add any item to the block sender list so that the registry key is created. Once you test this, then I will write a small piece of code that takes care of this.

Now paste this code in the VBA Editor. I have taken 2 blocks of code from a different site and modified it. I have mentioned it in the code. Rest is all by me.

'~~> 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
    Exit Sub
    '~~> 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

Open in new window


Sid
0
 

Author Closing Comment

by:jegajothy
ID: 35157050
I crown u as Super Guru, congratulations.
0
Highfive Gives IT Their Time Back

Highfive is so simple that setting up every meeting room takes just minutes and every employee will be able to start or join a call from any room with ease. Never be called into a meeting just to get it started again. This is how video conferencing should work!

 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35157061
Glad to be help ;)

Sid
0
 

Author Comment

by:jegajothy
ID: 35157269
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.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35157279
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35157458
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.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35157471
Nice to see that EE hadn't refreshed.  Ignore my first issue since I see you added the code.
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35157495
With that code added and with line #48 commented out I now get a type mismatch at line #94.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35157497
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

0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35157515
>>>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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35157523
The lone value in the pre-existing blocked list is also being duplicated.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35157590
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
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35157842
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
0
 
LVL 76

Expert Comment

by:David Lee
ID: 35157860
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.
0
 

Author Comment

by:jegajothy
ID: 35159013
To SiddharthRout and BlueDevilFan, hope u would give me the final fix of the code, as i am just a novice in this.
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35159022
jegajothy: I am already working on it :)

Sid
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35159289
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
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35159705
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

0
 

Author Comment

by:jegajothy
ID: 35164784
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
0
 
LVL 30

Expert Comment

by:SiddharthRout
ID: 35164866
Glad to  be of help :) Sorry about the earlier goof up. I had messed up the code while commenting it.

Sid
0

Featured Post

Want to promote your upcoming event?

Attending an event? Speaking at a conference? Or exhibiting at a tradeshow? Easily inform your contacts by using a promotional banner in your email signature. This will ensure your organization’s most important contacts are in the know.

Join & Write a Comment

Outlook Free & Paid Tools
Local Continuous Replication is a cost effective and quick way of backing up Exchange server data. The following article describes the steps required to configure Local Continuous Replication. Also, the article tells you how to restore from a backup…
The basic steps you have just learned will be implemented in this video. The basic steps are shown to configure an Exchange DAG in a live working Exchange Server Environment and manage the same (Exchange Server 2010 Software is used in a Windows Ser…
The viewer will learn how to  create a slide that will launch other presentations in Microsoft PowerPoint. In the finished slide, each item launches a new PowerPoint presentation and when each is finished it automatically comes back to this slide: …

707 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

15 Experts available now in Live!

Get 1:1 Help Now