Jegajothy vythilingam
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.
My OS is windows 7. thank u.
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
I'm still thinking but perhaps someone will have a more educated awareness of how it could be done.
Chris
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
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
ASKER
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
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
Sid
Also see this link. Not sure if this is what you want?
Sid
Sid
Sid
Since I didn't think the blocked list is exposed I am interested in your proposal ... so which link ;o)
Chris
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
Sid
Chris, the blocked sender list is stored in a unicode format in the following registry key.
"HKEY_CURRENT_USER\Softwar e\Microsof t\Windows
NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook \0a0d02000 0000000c00 0000000000 046\001f04 19a"
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
"HKEY_CURRENT_USER\Softwar
NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook
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
Still trying to find that link.
Sid
ASKER
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.
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.
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
jegajothy: Please do not close this question. I am working on a solution for you and I am real close.
Sid
Sid
Update!!!!!
Done Tested and Tried :)
Give me few moments to clean up the code and document it.
Sid
Done Tested and Tried :)
Give me few moments to clean up the code and document it.
Sid
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
I crown u as Super Guru, congratulations.
Glad to be help ;)
Sid
Sid
ASKER
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.
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.
Sid
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
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.
@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
>>>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
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
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
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@foo lmail.com
One of the entries had been duplicated, but that appears to have been my fault. I still get the type mismatch.
zales@e.zales.com;
zales@e.zales.com;Fool@foo
One of the entries had been duplicated, but that appears to have been my fault. I still get the type mismatch.
ASKER
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
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.
Sid
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
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
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
ASKER
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
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
Sid
How do you want the email triggered ... button or context menu for example?
Chris