mharcais
asked on
Modify script to extract First Name and Last name too...
HI, the following code extracts the email addresses of everyone in my Outlook.
However, all it does is extract the email addresses - I need it to also extract the display name beside the email address.
This is just code that I have pasted into a notepad file and saved as 'extract.vbs' and run on my desktop.
Please assist:
=========================
Dim mailAddr()
Sub AddtoMailArray(addr)
Dim isFound, arrLen
isFound = False
arrLen = getArrLength(mailAddr)
If arrLen > -1 Then
For I = 0 To arrLen
If LCase(addr) = mailAddr(I) Then
isFound = True
End If
Next
End If
If isFound = False Then
ReDim Preserve mailAddr(arrLen + 1)
mailAddr(arrLen + 1) = LCase(addr)
End If
End Sub
Function getArrLength(arr())
err.clear
On Error Resume Next
getArrLength = UBound(arr)
if err.number <> 0 then getArrLength = -1
End Function
Const olFolderSentMail = 5
Const ForWriting = 2
Dim OutLookApp, fdr, item, re
Dim cnt
Dim I
Erase mailAddr
On Error Resume Next
Set OutLookApp = GetObject(, "Outlook.Application")
If OutLookApp Is Nothing Then
Set OutLookApp = CreateObject("Outlook.Appl ication")
End If
On Error GoTo 0
Set fdr = OutLookApp.GetNamespace("M API").GetD efaultFold er(olFolde rSentMail)
cnt = 0
For Each item In fdr.Items
For Each re In item.Recipients
If I = item.Recipients.Count Then
tmp = tmp & re.Address
Else
tmp = tmp & re.Address & ", "
End If
AddtoMailArray re.Address
Next
cnt = cnt + 1
tmp = ""
Next
FileName = "C:\test1.txt"
Dim fso, file
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set file = fso.OpenTextFile(FileName, ForWriting, True)
If getArrLength(mailAddr) > -1 Then
For I = 0 To UBound(mailAddr)
file.Write mailAddr(I) & vbcrlf
Next
End If
file.Close
set file = nothing
set fso = nothing
MsgBox "Done!"
=======================
However, all it does is extract the email addresses - I need it to also extract the display name beside the email address.
This is just code that I have pasted into a notepad file and saved as 'extract.vbs' and run on my desktop.
Please assist:
=========================
Dim mailAddr()
Sub AddtoMailArray(addr)
Dim isFound, arrLen
isFound = False
arrLen = getArrLength(mailAddr)
If arrLen > -1 Then
For I = 0 To arrLen
If LCase(addr) = mailAddr(I) Then
isFound = True
End If
Next
End If
If isFound = False Then
ReDim Preserve mailAddr(arrLen + 1)
mailAddr(arrLen + 1) = LCase(addr)
End If
End Sub
Function getArrLength(arr())
err.clear
On Error Resume Next
getArrLength = UBound(arr)
if err.number <> 0 then getArrLength = -1
End Function
Const olFolderSentMail = 5
Const ForWriting = 2
Dim OutLookApp, fdr, item, re
Dim cnt
Dim I
Erase mailAddr
On Error Resume Next
Set OutLookApp = GetObject(, "Outlook.Application")
If OutLookApp Is Nothing Then
Set OutLookApp = CreateObject("Outlook.Appl
End If
On Error GoTo 0
Set fdr = OutLookApp.GetNamespace("M
cnt = 0
For Each item In fdr.Items
For Each re In item.Recipients
If I = item.Recipients.Count Then
tmp = tmp & re.Address
Else
tmp = tmp & re.Address & ", "
End If
AddtoMailArray re.Address
Next
cnt = cnt + 1
tmp = ""
Next
FileName = "C:\test1.txt"
Dim fso, file
Set fso = CreateObject("Scripting.Fi
Set file = fso.OpenTextFile(FileName,
If getArrLength(mailAddr) > -1 Then
For I = 0 To UBound(mailAddr)
file.Write mailAddr(I) & vbcrlf
Next
End If
file.Close
set file = nothing
set fso = nothing
MsgBox "Done!"
=======================
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
http://www.programmingmsaccess.com/Samples/VBAProcs/VBAProcsToManageOutlookContactsFromAccess.htm