Solved

Export Sent to addresses

Posted on 2010-11-22
21
460 Views
Last Modified: 2012-05-10
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


0
Comment
Question by:alexr54
  • 8
  • 8
  • 4
  • +1
21 Comments
 
LVL 74

Expert Comment

by:Jeffrey Coachman
ID: 34196842
Please click the "Request Attention" link and ask that the Exchange Server zone be added to this Question.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34197352
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
 
LVL 2

Author Comment

by:alexr54
ID: 34202023
Hi Chris,

Can you explain what this does? And what is it looking for and taking from?
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34202763
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
 
LVL 2

Author Comment

by:alexr54
ID: 34205502
Getting line 2 char 10, expected end of statement.
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34206116
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
 
LVL 13

Expert Comment

by:gbanik
ID: 34214301
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
 
LVL 13

Expert Comment

by:gbanik
ID: 34214307
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
 
LVL 2

Author Comment

by:alexr54
ID: 34245784
I am getting

Compile error:

User-defined type not defined
0
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34245947
Which code are you running and have you a response to my question about code placement?

Chris
0
Shouldn't all users have the same email signature?

You wouldn't let your users design their own business cards, would you? So, why do you let them design their own email signatures? Think of the damage they could be doing to your brand reputation! Choose the easy way to manage set up and add email signatures for all users.

 
LVL 2

Author Comment

by:alexr54
ID: 34248725
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34248848
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
 
LVL 2

Author Comment

by:alexr54
ID: 34248970
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
 
LVL 59

Expert Comment

by:Chris Bottomley
ID: 34249367
Can you get a snapshot of the code where it's loaded?

Chris
0
 
LVL 2

Author Comment

by:alexr54
ID: 34249481
error
0
 
LVL 13

Expert Comment

by:gbanik
ID: 34258775
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
 
LVL 13

Assisted Solution

by:gbanik
gbanik earned 100 total points
ID: 34258857
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
 
LVL 59

Accepted Solution

by:
Chris Bottomley earned 400 total points
ID: 34259092
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
 
LVL 2

Author Comment

by:alexr54
ID: 34259107
Thank you. I have never used macros for outlook before, so i am not sure what is refferenced or not.
0
 
LVL 2

Author Closing Comment

by:alexr54
ID: 34259216
Awarded 400 points for the answer which i am using. Awarded 100 for the helpful tips.
0
 
LVL 59

Expert Comment

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

Featured Post

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!

Join & Write a Comment

Suggested Solutions

Title # Comments Views Activity
Outlook 2010 Archive 3 40
outlook 2013 3 25
Exchange 2013 - Restore deleted mailbox from DPM 5 16
Exchange 2013 Errors 2 19
Marketers need statistics and metrics like everybody else needs oxygen. In this article we explain how to enable marketing campaign statistics for Microsoft Exchange mail.
If you don't know how to downgrade, my instructions below should be helpful.
This video discusses moving either the default database or any database to a new volume.
Access reports are powerful and flexible. Learn how to create a query and then a grouped report using the wizard. Modify the report design after the wizard is done to make it look better. There will be another video to explain how to put the final p…

706 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

17 Experts available now in Live!

Get 1:1 Help Now