Export Sent to addresses

Can anyone supply me with a script which can export to txt or csv all sent to Email addresses from my outlook 2003?

In this script i would need the output to be a clean format. Outlook is connected to exchange, therefore when i try to do a regular export, its very messy with CN= blah/blah/blah.com...

I just need all addresses clean like youremail@youremail.com


LVL 2
alexr54Asked:
Who is Participating?
 
Chris BottomleySoftware Quality Lead EngineerCommented:
In the snippet, in there are som elines that haven't come accross correctly with cut and paste so retry here

Note it's nothing at all to do with scripting runtime library.

Chris
Sub getrecip()
Dim dict As Object
Dim mai As Object
Dim recip As Recipient
Dim str As String
Dim outfile As Object
Dim arr As Variant
Dim itm As Variant

   Set dict = CreateObject("scripting.dictionary")
   dict.CompareMode = vbTextCompare
   For Each mai In Application.Session.GetDefaultFolder(olFolderSentMail).items
       If mai.Class = olMail Then
           Debug.Print mai.subject
           On Error GoTo getnext
           For Each recip In mai.Recipients
               str = getSMTPaddress(recip.Address)
               If str <> "" And Not dict.Exists(str) Then dict.Add str, str
           Next
getnext:
           Set mai = Nothing
       End If
   Next
   Set outfile = getTextFile("c:\deleteme\", "gashisme.txt")
   arr = dict.items
   For Each itm In arr
       outfile.WriteLine itm
   Next
End Sub

Function getSMTPaddress(ByVal strAddress As String)
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim oCon As ContactItem
Dim strKey As String
Dim oRec As Recipient
Dim strRet As String
Dim fldr As MAPIFolder
   'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
   On Error Resume Next
   Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Item("Random")
   If fldr Is Nothing Then
       Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Add "Random"
       Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Item("Random")
   End If
   On Error GoTo 0
   If CInt(Left(Application.Version, 2)) >= 12 Then
       Set oRec = Session.CreateRecipient(strAddress)
       If oRec.Resolve Then
           strRet = oRec.AddressEntry.getexchangeuser.PrimarySmtpAddress
       End If
   End If
   If Not strRet = "" Then GoTo ReturnValue
   'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
   'How it works
   '============
   '1) It will create a new contact item
   '2) Set it's email address to the value passed by you, it could be X500,X400 or any type of email address stored in the AD
   '3) We will assign a random key to this contact item and save it in its Fullname to search it later
   '4) Next we will save it to local contacts folder
   '5) Outlook will try to resolve the email address & make AD callif required else take the Primary SMTP address from its cache and append it to Display name
   '6) The display name will be something like this " (email.address@server.com )"
   '7) Now we need to parse the Display name and delete the contact from contacts folder
   '8) Once the contact is deleted it will go to Deleted Items folder, after searching the contact using the unique random key generated in step 3
   '9) We then need to delete it from Deleted Items folder as well, to clean all the traces
   Set oCon = fldr.items.Add(olContactItem)
   oCon.Email1Address = strAddress
   strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
   oCon.FullName = strKey
   oCon.Save
   strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(", ""), ")", ""), strKey, ""))
   oCon.Delete
   Set oCon = Nothing
   Set oCon = Session.GetDefaultFolder(olFolderDeletedItems).items.Find("[Subject]=" & strKey)
   If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
   getSMTPaddress = strRet
End Function

Function getTextFile(outputPath As String, outputFileName As String) As Object
'    Set outputfile = getTextFile("c:\deleteme22\sub2\temp", "gashisme.txt")
'    outputfile.WriteLine "Something for me"
'    outputfile.Close
Dim outputfile As Object
Dim fso As Object
Dim pathComponents() As String
Dim pathComponent As Integer
Dim fldr As String

   If Right(outputPath, 1) = "\" Then outputPath = Left(outputPath, Len(outputPath) - 1)
   Set fso = CreateObject("Scripting.FileSystemObject")
   pathComponents = Split(outputPath, "\")
   For pathComponent = 0 To UBound(pathComponents)
       If pathComponent <> 0 Then
           fldr = fldr & "\"
       End If
       fldr = fldr & pathComponents(pathComponent)
       If Not fso.FolderExists(fldr) Then
           fso.CreateFolder fldr
       End If
   Next
   Set outputfile = fso.CreateTextFile(outputPath & "\" & outputFileName, True)
   outputfile.WriteLine "File Initialised on " & Format(Date, "dd mmm yyyy") & " at " & Format(Time(), "hh:mm")
   outputfile.WriteLine "========================================"
   outputfile.WriteLine ""
   Set getTextFile = outputfile

End Function

Open in new window

0
 
Jeffrey CoachmanMIS LiasonCommented:
Please click the "Request Attention" link and ask that the Exchange Server zone be added to this Question.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
How about the following?

Chris
Sub getrecip()
Dim dict As Object
Dim mai As Object
Dim recip As Recipient
Dim str As String
Dim outfile As Object
Dim arr As Variant
Dim itm As Variant

   Set dict = CreateObject("scripting.dictionary")
   dict.CompareMode = vbTextCompare
   For Each mai In Application.Session.GetDefaultFolder(olFolderSentMail).items
       If mai.Class = olMail Then
           Debug.Print mai.subject
           On Error GoTo getnext
           For Each recip In mai.Recipients
               str = getSMTPaddress(recip.Address)
               If str <> "" And Not dict.exists(str) Then dict.Add str, str
           Next
getnext:
           Set mai = Nothing
       End If
   Next
   Set outfile = getTextFile("c:\deleteme\", "gashisme.txt")
   arr = dict.items
   For Each itm In arr
       outfile.WriteLine itm
   Next
End Sub

Function getSMTPaddress(ByVal strAddress As String)
' As supplied by Vikas Verma ... see
' http://blogs.msdn.com/vikas/archive/2007/10/24/oom-getting-primary-smtp-address-from-x400-x500-sip-ccmail-etc.aspx
Dim oCon As ContactItem
Dim strKey As String
Dim oRec As Recipient
Dim strRet As String
Dim fldr As MAPIFolder
   'IF OUTLOOK VERSION IS >= 2007 THEN USES NATIVE OOM PROPERTIES AND METHODS
   On Error Resume Next
   Set fldr = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.item("Random")
   If fldr Is Nothing Then
       Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.Add
"Random"
       Set fldr =
Application.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts).Folders.item("Random")
   End If
   On Error GoTo 0
   If CInt(Left(Application.Version, 2)) >= 12 Then
       Set oRec = Session.CreateRecipient(strAddress)
       If oRec.Resolve Then
           strRet = oRec.AddressEntry.getexchangeuser.PrimarySmtpAddress
       End If
   End If
   If Not strRet = "" Then GoTo ReturnValue
   'IF OUTLOOK VERSION IS < 2007 THEN USES LITTLE HACK
   'How it works
   '============
   '1) It will create a new contact item
   '2) Set it's email address to the value passed by you, it could be
X500,X400 or any type of email address stored in the AD
   '3) We will assign a random key to this contact item and save it
in its Fullname to search it later
   '4) Next we will save it to local contacts folder
   '5) Outlook will try to resolve the email address & make AD call
if required else take the Primary SMTP address from its cache and
append it to Display name
   '6) The display name will be something like this " (
email.address@server.com )"
   '7) Now we need to parse the Display name and delete the contact
from contacts folder
   '8) Once the contact is deleted it will go to Deleted Items
folder, after searching the contact using the unique random key
generated in step 3
   '9) We then need to delete it from Deleted Items folder as well,
to clean all the traces
   Set oCon = fldr.items.Add(olContactItem)
   oCon.Email1Address = strAddress
   strKey = "_" & Replace(Rnd * 100000 & Format(Now, "DDMMYYYYHmmss"), ".", "")
   oCon.FullName = strKey
   oCon.Save
   strRet = Trim(Replace(Replace(Replace(oCon.Email1DisplayName, "(",
""), ")", ""), strKey, ""))
   oCon.Delete
   Set oCon = Nothing
   Set oCon = Session.GetDefaultFolder(olFolderDeletedItems).items.Find("[Subject]="
& strKey)
   If Not oCon Is Nothing Then oCon.Delete
ReturnValue:
   getSMTPaddress = strRet
End Function

Function getTextFile(outputPath As String, outputFileName As String) As Object
'    Set outputfile = getTextFile("c:\deleteme22\sub2\temp", "gashisme.txt")
'    outputfile.WriteLine "Something for me"
'    outputfile.Close
Dim outputfile As Object
Dim fso As Object
Dim pathComponents() As String
Dim pathComponent As Integer
Dim fldr As String

   If Right(outputPath, 1) = "\" Then outputPath = Left(outputPath,
Len(outputPath) - 1)
   Set fso = CreateObject("Scripting.FileSystemObject")
   pathComponents = Split(outputPath, "\")
   For pathComponent = 0 To UBound(pathComponents)
       If pathComponent <> 0 Then
           fldr = fldr & "\"
       End If
       fldr = fldr & pathComponents(pathComponent)
       If Not fso.FolderExists(fldr) Then
           fso.CreateFolder fldr
       End If
   Next
   Set outputfile = fso.CreateTextFile(outputPath & "\" & outputFileName, True)
   outputfile.WriteLine "File Initialised on " & Format(Date, "dd mmm
yyyy") & " at " & Format(Time(), "hh:mm")
   outputfile.WriteLine "========================================"
   outputfile.WriteLine ""
   Set getTextFile = outputfile

End Function

Open in new window

0
Has Powershell sent you back into the Stone Age?

If managing Active Directory using Windows Powershell® is making you feel like you stepped back in time, you are not alone.  For nearly 20 years, AD admins around the world have used one tool for day-to-day AD management: Hyena. Discover why.

 
alexr54Author Commented:
Hi Chris,

Can you explain what this does? And what is it looking for and taking from?
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
It cycles around every email in your sent folder and then every recipient therein and creates a file with the email addys for them all.

Chris
0
 
alexr54Author Commented:
Getting line 2 char 10, expected end of statement.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
How are you running this ... for that error I suspect as a VBS - and in which case I need to make a number of changes.

ALternatively insert it into a code module in outlook and it will run from there:

Chris


To Create a macro:
------------------

Alt + F11 to open the macro editor

  For User Code:
     Insert | Module to insert a code module into the project
     In the project tree select the module.
     Insert the required macro(s) into the selected module, ('Module1' or similar)

Close the Visual Basic Editor.

To run a macro:
---------------

Alt + F8
Select the macro
Select 'Run'

Check Security as appropriate:
------------------------------

In the application select Tools | Macro | Security
=========================
2003 and earlier
-------------------------
      : Select Medium
      : Select OK
=========================

==================================================================================
2007
----------------------------------------------------------------------------------
      : Outlook Application - Warnings for all Macros
----------------------------------------------------------------------------------
      : All Other APplications - Enable a trusted location and inhibit macros otherwise so do both!
      : Disable Macros
            Office Button, (top left of the screen)
            Options
            Trust Centre
            Trust Centre Settings
            MAcro Settings
            Disable All MAcros with warnings
      : Enable Trusted Locations
            Office Button, (top left of the screen)
            Options
            Trust Centre
            Trust Centre Settings
            Trusted Locations
            Add a preferred location
            ENSURE YOUR FILE IS IN A TRUSTED LOCATION
            Re-open to ensure it is recognised if the above has been changed
            
      : Select OK
==================================================================================
0
 
gbanikCommented:
Try putting this code in your Outlook VBA Project and running it. It would create a CSV file in your C:\
Public Sub FetchAllEmailAddress()
Dim oDefFolderType As OlDefaultFolders
oDefFolderType = olFolderSentMail

Dim oFolder As Folder, olNS As Outlook.NameSpace, oMailItem As MailItem, obj, nCtr As Integer, sTemp As String
Dim fso As New Scripting.FileSystemObject, txt As TextStream, oRec As Recipient

Set olNS = Application.GetNamespace("MAPI")
Set oFolder = olNS.GetDefaultFolder(oDefFolderType)
Set txt = fso.OpenTextFile("C:\SentMailAddr_" & Format(Now(), "dd-mmm-yy-hh-m-s") & ".csv", ForWriting, True)

For Each obj In oFolder.Items
    sTemp = ""
    If TypeName(obj) = "MailItem" Then
        Set oMailItem = obj
        For Each oRec In oMailItem.Recipients
            sTemp = sTemp & "," & oRec.Address
        Next
        If Len(sTemp) > 0 Then txt.WriteLine Mid(sTemp, 2)
    End If
Next

txt.Close
Set txt = Nothing
Set fso = Nothing
End Sub

Open in new window

0
 
gbanikCommented:
The above code is applicable to any folder, not just Sent Items. Just change the value of the variable "oDefFolderType" to your desired folder.
0
 
alexr54Author Commented:
I am getting

Compile error:

User-defined type not defined
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Which code are you running and have you a response to my question about code placement?

Chris
0
 
alexr54Author Commented:
I am running through outlook 2003 macros.

This was Gbanik's code.

Also your code throws an error:

Compile error:

Arguement not optional and highlights

Function getSMTPaddress(ByVal strAddress As String)
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
I've just run my code agaian with no error - can you confirm it highlights the line

Function getSMTPaddress(ByVal strAddress As String)

I really cannot see how that can happen ... also can you tell me anything about the mail folder selected in outlook before you run it, and do you get anything created in the outlput file at all?

Chris
0
 
alexr54Author Commented:
Its very possible i am doing something wrong here since i am completely new to outlook macros.

There is no file made at all. I am running this while in "Sent Items" in outlook 2003.

When i run the macro.

Compile Error:

Argument not optional

When i hit ok,

the line "Function getSMTPaddress(ByVal strAddress As String)" get highlighted yellow. And still no file.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Can you get a snapshot of the code where it's loaded?

Chris
0
 
alexr54Author Commented:
error
0
 
gbanikCommented:
Hi alexr54,

Sorry could not appear earlier. The only problem that you are encountering in my code is that the code expects a reference to the Microsoft Scripting Runtime. Thats it!!

Please add the same in your references and watch it run!

To add to references, got VBA Editor...
Goto Tools > References > Choose "Microsoft Scripting Runtime" > choose OK.

Run the macro again!
0
 
gbanikCommented:
If you need a non-reference code explicitly for some reason, here u are....

Replace this

Dim oFolder As Folder, olNS As Outlook.NameSpace, oMailItem As MailItem, obj, nCtr As Integer, sTemp As String
Dim fso As New Scripting.FileSystemObject, txt As TextStream, oRec As Recipient

with

Dim oFolder As Folder, olNS As Outlook.Namespace, oMailItem As MailItem, obj, nCtr As Integer, sTemp As String
Dim fso, txt, oRec As Recipient
Set fso = CreateObject("Scripting.FileSystemObject")

rest remains the same.
0
 
alexr54Author Commented:
Thank you. I have never used macros for outlook before, so i am not sure what is refferenced or not.
0
 
alexr54Author Commented:
Awarded 400 points for the answer which i am using. Awarded 100 for the helpful tips.
0
 
Chris BottomleySoftware Quality Lead EngineerCommented:
Ah, well for anyone looking at the thread you should know that your request was to replace exchange addresses with SMTP addresses.  The post from gbanik will not do this ... you were only going to get pukka emails from the external mail addresses, internal ones were going to be the exchange addresses - i.e. all the gibberish you wanted to avoid.

That said, i'm glad to have helped.

Chris
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.