Outlook Macro that can query each user in the folder and get the title of that user to an txt or excel file.

Hi,

Outlook Macro that can query each user in the folder and get the title of that user to an txt or excel file.
So i know with what designation i am dealing when replying to them... :-)

Query each mail on there user and get there title from the GAL properties.

REgards
Sharath
LVL 11
bsharathAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

Chris BottomleySoftware Quality Lead EngineerCommented:
I think I can help here, can you confirm however you want the titles for every sender of an email in a folder into a txt file ... what other information do you want to save therein?  Is ther any chance that senders outside of the GAL may exist n the folder?

Chris
bsharathAuthor Commented:
There are chances of external mail id  so such email's can be omitted.

For this post its just title. But actually i need to pull a lot of data. I shall post that in the next Q....
bsharathAuthor Commented:
There are chances of external mail id  so such email's can be omitted.

For this post its just title. But actually i need to pull a lot of data. I shall post that in the next Q....
Determine the Perfect Price for Your IT Services

Do you wonder if your IT business is truly profitable or if you should raise your prices? Learn how to calculate your overhead burden with our free interactive tool and use it to determine the right price for your IT services. Download your free eBook now!

Chris BottomleySoftware Quality Lead EngineerCommented:
How about the following VBS script ... paste into a new file called somethingorother.vbs.

I don't know if it could be easier ... but it works for me.

Chris
dim olApp
dim olNS
dim olFolder
dim olMai
dim dataArray
dim logname
dim dictNames
dim dictItem
dim dictItems
dim fso
dim outputFile
dim outputPath
dim outputFileName
 
const retparams_Title = 1
const retparams_firstname = 2
const retparams_surName = 3
const retparams_login = 4
const retparams_telephonenumber = 5
const retparams_emailaddress = 6
const retparams_manager = 7
dim lastDatum : lastdatum = 7
dim intDatum
 
    outputpath = "c:\ManagerList"
    outputFileName = "Manager Login.txt"
    set fso = createobject("scripting.filesystemobject")
    if not fso.folderexists(outputpath) then fso.createfolder outputpath
    set outputfile = fso.createtextfile(outputpath & "\" & outputfilename, true)
 
    set screen = wscript.stdout 
    set dictNames = createobject("scripting.dictionary")
    on error resume next
    set olApp = getobject(, "outlook.application")
    on error goto 0
    if olApp is nothing then set olApp = createobject("outlook.application")
    set olNS = olApp.getnamespace("MAPI")
    screen.writeline "Select Folder!"
    set olFolder = olNS.pickfolder
    screen.write "Gathering email addresses "
    for each olMai in olFolder.items
        screen.write "."
        if olmai.class = 43 then 'olmail
            if instr(olmai.senderemailaddress, "@") = 0 and olmai.senderemailaddress <> "" then
'wscript.echo right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                logname = right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, 
 
"="))
                 if not dictnames.exists (lcase(logname)) then
		     dictnames.add lcase(logname), ucase(logname)
                 end if
'                dataArray = CRB_getADSInfo(logname)
'                for intdatum = 1 to ubound(dataArray)
'                    wscript.echo dataarray(intdatum)
'                next
'                wscript.echo "#################################"
            end if
        end if
    next
    dictitems = dictnames.keys
    screen.writeline
    screen.writeline "Processing Unique Data"
    for each dictitem in dictitems
        dataArray = CRB_getADSInfo(dictnames.item(dictitem))
        if trim(dataarray(retparams_Title)) <> "" then outputfile.write dataarray(retparams_Title) & " "
        if trim(dataarray(retparams_firstname)) <> "" then outputfile.write dataarray(retparams_firstname) & " "
        if trim(dataarray(retparams_surname)) <> "" then outputfile.write dataarray(retparams_surname)
        if trim(dataarray(retparams_login)) <> "" then outputfile.write ", (" & dataarray(retparams_login) & " - "
        if trim(dataarray(retparams_emailaddress)) <> "" then outputfile.write dataarray(retparams_emailaddress) & ")."
        outputfile.writeline
'        for intdatum = 1 to ubound(dataArray)
             wscript.echo "Processed sender " & dataarray(retparams_login)
'        next
'        wscript.echo "#################################"
    next
 
'########################################################################################
Function CRB_getADSInfo(struserid)
Dim conn
Dim sysinfo
Dim rs
Dim user
Dim strDC
 
dim retparams()
redim retparams(lastDatum)
 
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
 
    set sysinfo = CreateObject("adsysteminfo")
    strDC = Right(sysinfo.UserName, Len(sysinfo.UserName) - InStr(LCase(sysinfo.UserName), "dc=") + 1)
 
    Set rs = conn.Execute("<LDAP://" & strDC & ">;(&(objectCategory=person)(objectClass=user)(sAMAccountName=" & struserid & 
 
"));adsPath;subTree")
 
    If Not rs.EOF Then
        Set user = GetObject(rs("adsPath"))
        retparams(retparams_Title) = user.title
        retparams(retparams_firstname) = user.FirstName
        retparams(retparams_surname) = user.sn
        retparams(retparams_login) = user.cn
        retparams(retparams_telephonenumber) = user.telephonenumber
        retparams(retparams_emailaddress) = user.emailAddress
        retparams(retparams_manager) = UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, 
 
",") - 4))
'        wscript.echo user.title
'        wscript.echo user.FirstName & " " & user.sn
'        wscript.echo user.cn
'        wscript.echo user.telephonenumber
'        wscript.echo user.emailAddress
'        wscript.echo UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, ",") - 4))
    End If
    CRB_getADSInfo = retparams
Set user = Nothing
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
 
End Function
'##################################################################################################### 

Open in new window

bsharathAuthor Commented:
Thanks Shall try and get back...
Chris BottomleySoftware Quality Lead EngineerCommented:
Any feedbackon this one?

Chris
bsharathAuthor Commented:
I get this

---------------------------
Windows Script Host
---------------------------
Script:      D:\Get data.vbs
Line:      46
Char:      126
Error:      Syntax error
Code:      800A03EA
Source:       Microsoft VBScript compilation error

---------------------------
OK  
---------------------------
bsharathAuthor Commented:
I get this

---------------------------
Windows Script Host
---------------------------
Script:      D:\Get data.vbs
Line:      46
Char:      126
Error:      Syntax error
Code:      800A03EA
Source:       Microsoft VBScript compilation error

---------------------------
OK  
---------------------------
Chris BottomleySoftware Quality Lead EngineerCommented:
A spurious hard return snuck in:

try the following

Chris
dim olApp
dim olNS
dim olFolder
dim olMai
dim dataArray
dim logname
dim dictNames
dim dictItem
dim dictItems
dim fso
dim outputFile
dim outputPath
dim outputFileName
 
const retparams_Title = 1
const retparams_firstname = 2
const retparams_surName = 3
const retparams_login = 4
const retparams_telephonenumber = 5
const retparams_emailaddress = 6
const retparams_manager = 7
dim lastDatum : lastdatum = 7
dim intDatum
 
    outputpath = "c:\ManagerList"
    outputFileName = "Manager Login.txt"
    set fso = createobject("scripting.filesystemobject")
    if not fso.folderexists(outputpath) then fso.createfolder outputpath
    set outputfile = fso.createtextfile(outputpath & "\" & outputfilename, true)
 
    set screen = wscript.stdout 
    set dictNames = createobject("scripting.dictionary")
    on error resume next
    set olApp = getobject(, "outlook.application")
    on error goto 0
    if olApp is nothing then set olApp = createobject("outlook.application")
    set olNS = olApp.getnamespace("MAPI")
    screen.writeline "Select Folder!"
    set olFolder = olNS.pickfolder
    screen.write "Gathering email addresses "
    for each olMai in olFolder.items
        screen.write "."
        if olmai.class = 43 then 'olmail
            if instr(olmai.senderemailaddress, "@") = 0 and olmai.senderemailaddress <> "" then
'wscript.echo right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                logname = right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                 if not dictnames.exists (lcase(logname)) then
		     dictnames.add lcase(logname), ucase(logname)
                 end if
'                dataArray = CRB_getADSInfo(logname)
'                for intdatum = 1 to ubound(dataArray)
'                    wscript.echo dataarray(intdatum)
'                next
'                wscript.echo "#################################"
            end if
        end if
    next
    dictitems = dictnames.keys
    screen.writeline
    screen.writeline "Processing Unique Data"
    for each dictitem in dictitems
        dataArray = CRB_getADSInfo(dictnames.item(dictitem))
        if trim(dataarray(retparams_Title)) <> "" then outputfile.write dataarray(retparams_Title) & " "
        if trim(dataarray(retparams_firstname)) <> "" then outputfile.write dataarray(retparams_firstname) & " "
        if trim(dataarray(retparams_surname)) <> "" then outputfile.write dataarray(retparams_surname)
        if trim(dataarray(retparams_login)) <> "" then outputfile.write ", (" & dataarray(retparams_login) & " - "
        if trim(dataarray(retparams_emailaddress)) <> "" then outputfile.write dataarray(retparams_emailaddress) & ")."
        outputfile.writeline
'        for intdatum = 1 to ubound(dataArray)
             wscript.echo "Processed sender " & dataarray(retparams_login)
'        next
'        wscript.echo "#################################"
    next
 
'########################################################################################
Function CRB_getADSInfo(struserid)
Dim conn
Dim sysinfo
Dim rs
Dim user
Dim strDC
 
dim retparams()
redim retparams(lastDatum)
 
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
 
    set sysinfo = CreateObject("adsysteminfo")
    strDC = Right(sysinfo.UserName, Len(sysinfo.UserName) - InStr(LCase(sysinfo.UserName), "dc=") + 1)
 
    Set rs = conn.Execute("<LDAP://" & strDC & ">;(&(objectCategory=person)(objectClass=user)(sAMAccountName=" & struserid & 
 
"));adsPath;subTree")
 
    If Not rs.EOF Then
        Set user = GetObject(rs("adsPath"))
        retparams(retparams_Title) = user.title
        retparams(retparams_firstname) = user.FirstName
        retparams(retparams_surname) = user.sn
        retparams(retparams_login) = user.cn
        retparams(retparams_telephonenumber) = user.telephonenumber
        retparams(retparams_emailaddress) = user.emailAddress
        retparams(retparams_manager) = UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, 
 
",") - 4))
'        wscript.echo user.title
'        wscript.echo user.FirstName & " " & user.sn
'        wscript.echo user.cn
'        wscript.echo user.telephonenumber
'        wscript.echo user.emailAddress
'        wscript.echo UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, ",") - 4))
    End If
    CRB_getADSInfo = retparams
Set user = Nothing
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
 
End Function
'##################################################################################################### 

Open in new window

bsharathAuthor Commented:
I Get this

---------------------------
Windows Script Host
---------------------------
Script:      D:\Get data.vbs
Line:      92
Char:      126
Error:      Syntax error
Code:      800A03EA
Source:       Microsoft VBScript compilation error

---------------------------
OK  
---------------------------
Chris BottomleySoftware Quality Lead EngineerCommented:
It snuck in again!

Look at your script for the line 92 as above, see there is a blank in line 93 and some text on line 94.

Delete to ensure the text in line 94 follows on from line 92 end.

Chris
bsharathAuthor Commented:
I get this now

---------------------------
Windows Script Host
---------------------------
Script:      C:\Get Data.vbs
Line:      36
Char:      5
Error:      Object required
Code:      800A01A8
Source:       Microsoft VBScript runtime error

---------------------------
OK  
---------------------------

Where should i mention the input
Which folder does it scan?
Chris BottomleySoftware Quality Lead EngineerCommented:
1. can you post the code as you have it now ... and the folder is requested a few lines later in the code.

Chris
bsharathAuthor Commented:
Here is the code
dim olApp
dim olNS
dim olFolder
dim olMai
dim dataArray
dim logname
dim dictNames
dim dictItem
dim dictItems
dim fso
dim outputFile
dim outputPath
dim outputFileName
 
const retparams_Title = 1
const retparams_firstname = 2
const retparams_surName = 3
const retparams_login = 4
const retparams_telephonenumber = 5
const retparams_emailaddress = 6
const retparams_manager = 7
dim lastDatum : lastdatum = 7
dim intDatum
 
    outputpath = "c:\ManagerList"
    outputFileName = "Manager Login.txt"
    set fso = createobject("scripting.filesystemobject")
    if not fso.folderexists(outputpath) then fso.createfolder outputpath
    set outputfile = fso.createtextfile(outputpath & "\" & outputfilename, true)
 
    set screen = wscript.stdout 
    set dictNames = createobject("scripting.dictionary")
    on error resume next
    set olApp = getobject(, "outlook.application")
    on error goto 0
    if olApp is nothing then set olApp = createobject("outlook.application")
    set olNS = olApp.getnamespace("MAPI")
    screen.writeline "Select Folder!"
    set olFolder = olNS.pickfolder
    screen.write "Gathering email addresses "
    for each olMai in olFolder.items
        screen.write "."
        if olmai.class = 43 then 'olmail
            if instr(olmai.senderemailaddress, "@") = 0 and olmai.senderemailaddress <> "" then
'wscript.echo right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                logname = right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                 if not dictnames.exists (lcase(logname)) then
		     dictnames.add lcase(logname), ucase(logname)
                 end if
'                dataArray = CRB_getADSInfo(logname)
'                for intdatum = 1 to ubound(dataArray)
'                    wscript.echo dataarray(intdatum)
'                next
'                wscript.echo "#################################"
            end if
        end if
    next
    dictitems = dictnames.keys
    screen.writeline
    screen.writeline "Processing Unique Data"
    for each dictitem in dictitems
        dataArray = CRB_getADSInfo(dictnames.item(dictitem))
        if trim(dataarray(retparams_Title)) <> "" then outputfile.write dataarray(retparams_Title) & " "
        if trim(dataarray(retparams_firstname)) <> "" then outputfile.write dataarray(retparams_firstname) & " "
        if trim(dataarray(retparams_surname)) <> "" then outputfile.write dataarray(retparams_surname)
        if trim(dataarray(retparams_login)) <> "" then outputfile.write ", (" & dataarray(retparams_login) & " - "
        if trim(dataarray(retparams_emailaddress)) <> "" then outputfile.write dataarray(retparams_emailaddress) & ")."
        outputfile.writeline
'        for intdatum = 1 to ubound(dataArray)
             wscript.echo "Processed sender " & dataarray(retparams_login)
'        next
'        wscript.echo "#################################"
    next
 
'########################################################################################
Function CRB_getADSInfo(struserid)
Dim conn
Dim sysinfo
Dim rs
Dim user
Dim strDC
 
dim retparams()
redim retparams(lastDatum)
 
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
 
    set sysinfo = CreateObject("adsysteminfo")
    strDC = Right(sysinfo.UserName, Len(sysinfo.UserName) - InStr(LCase(sysinfo.UserName), "dc=") + 1)
 
    Set rs = conn.Execute("<LDAP://" & strDC & ">;(&(objectCategory=person)(objectClass=user)(sAMAccountName=" & struserid & "));adsPath;subTree")
 
    If Not rs.EOF Then
        Set user = GetObject(rs("adsPath"))
        retparams(retparams_Title) = user.title
        retparams(retparams_firstname) = user.FirstName
        retparams(retparams_surname) = user.sn
        retparams(retparams_login) = user.cn
        retparams(retparams_telephonenumber) = user.telephonenumber
        retparams(retparams_emailaddress) = user.emailAddress
        retparams(retparams_manager) = UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager,",") - 4))
'        wscript.echo user.title
'        wscript.echo user.FirstName & " " & user.sn
'        wscript.echo user.cn
'        wscript.echo user.telephonenumber
'        wscript.echo user.emailAddress
'        wscript.echo UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, ",") - 4))
    End If
    CRB_getADSInfo = retparams
Set user = Nothing
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
 
End Function
'##################################################################################################### 

Open in new window

Chris BottomleySoftware Quality Lead EngineerCommented:
I set my PC up to use Csript .. perhaps that was the problem.

Try th efollowing.

Chris
dim olApp
dim olNS
dim olFolder
dim olMai
dim dataArray
dim logname
dim dictNames
dim dictItem
dim dictItems
dim fso
dim outputFile
dim outputPath
dim outputFileName
 
const retparams_Title = 1
const retparams_firstname = 2
const retparams_surName = 3
const retparams_login = 4
const retparams_telephonenumber = 5
const retparams_emailaddress = 6
const retparams_manager = 7
dim lastDatum : lastdatum = 7
dim intDatum
 
    outputpath = "c:\ManagerList"
    outputFileName = "Manager Login.txt"
    set fso = createobject("scripting.filesystemobject")
    if not fso.folderexists(outputpath) then fso.createfolder outputpath
    set outputfile = fso.createtextfile(outputpath & "\" & outputfilename, true)
 
'    set screen = wscript.stdout 
    set dictNames = createobject("scripting.dictionary")
    on error resume next
    set olApp = getobject(, "outlook.application")
    on error goto 0
    if olapp is nothing then set olapp = createobject("Outlook.Application")
    set olNS = olApp.getnamespace("MAPI")
'    screen.writeline "Select Folder!"
    set olFolder = olNS.pickfolder
'    screen.write "Gathering email addresses "
    for each olMai in olFolder.items
'        screen.write "."
        if olmai.class = 43 then 'olmail
            if instr(olmai.senderemailaddress, "@") = 0 and olmai.senderemailaddress <> "" then
'wscript.echo right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                logname = right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                 if not dictnames.exists (lcase(logname)) then
		     dictnames.add lcase(logname), ucase(logname)
                 end if
'                dataArray = CRB_getADSInfo(logname)
'                for intdatum = 1 to ubound(dataArray)
'                    wscript.echo dataarray(intdatum)
'                next
'                wscript.echo "#################################"
            end if
        end if
    next
    dictitems = dictnames.keys
'    screen.writeline
'    screen.writeline "Processing Unique Data"
    for each dictitem in dictitems
        dataArray = CRB_getADSInfo(dictnames.item(dictitem))
        if trim(dataarray(retparams_Title)) <> "" then outputfile.write dataarray(retparams_Title) & " "
        if trim(dataarray(retparams_firstname)) <> "" then outputfile.write dataarray(retparams_firstname) & " "
        if trim(dataarray(retparams_surname)) <> "" then outputfile.write dataarray(retparams_surname)
        if trim(dataarray(retparams_login)) <> "" then outputfile.write ", (" & dataarray(retparams_login) & " - "
        if trim(dataarray(retparams_emailaddress)) <> "" then outputfile.write dataarray(retparams_emailaddress) & ")."
        outputfile.writeline
'        for intdatum = 1 to ubound(dataArray)
             wscript.echo "Processed sender " & dataarray(retparams_login)
'        next
'        wscript.echo "#################################"
    next
 
'########################################################################################
Function CRB_getADSInfo(struserid)
Dim conn
Dim sysinfo
Dim rs
Dim user
Dim strDC
 
dim retparams()
redim retparams(lastDatum)
 
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
 
    set sysinfo = CreateObject("adsysteminfo")
    strDC = Right(sysinfo.UserName, Len(sysinfo.UserName) - InStr(LCase(sysinfo.UserName), "dc=") + 1)
 
    Set rs = conn.Execute("<LDAP://" & strDC & ">;(&(objectCategory=person)(objectClass=user)(sAMAccountName=" & struserid & "));adsPath;subTree")
 
    If Not rs.EOF Then
        Set user = GetObject(rs("adsPath"))
        retparams(retparams_Title) = user.title
        retparams(retparams_firstname) = user.FirstName
        retparams(retparams_surname) = user.sn
        retparams(retparams_login) = user.cn
        retparams(retparams_telephonenumber) = user.telephonenumber
        retparams(retparams_emailaddress) = user.emailAddress
        retparams(retparams_manager) = UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager,",") - 4))
'        wscript.echo user.title
'        wscript.echo user.FirstName & " " & user.sn
'        wscript.echo user.cn
'        wscript.echo user.telephonenumber
'        wscript.echo user.emailAddress
'        wscript.echo UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, ",") - 4))
    End If
    CRB_getADSInfo = retparams
Set user = Nothing
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
 
End Function
'##################################################################################################### 
 

Open in new window

bsharathAuthor Commented:
I get this

---------------------------
Windows Script Host
---------------------------
Script:      D:\Get data.vbs
Line:      38
Char:      5
Error:      The handle is invalid.
Code:      80070006
Source:       (null)

---------------------------
OK  
---------------------------

Is there any thing i need to change in the code...
bsharathAuthor Commented:
I get this

---------------------------
Windows Script Host
---------------------------
Script:      D:\Get data.vbs
Line:      38
Char:      5
Error:      The handle is invalid.
Code:      80070006
Source:       (null)

---------------------------
OK  
---------------------------

Is there any thing i need to change in the code...
Chris BottomleySoftware Quality Lead EngineerCommented:
I normally already have outlook open.  I have reproduced an issue with my syntax when outlook is closed so please see if the following is any better.

Chris
dim olApp
dim olNS
dim olFolder
dim olMai
dim dataArray
dim logname
dim dictNames
dim dictItem
dim dictItems
dim fso
dim outputFile
dim outputPath
dim outputFileName
 
const retparams_Title = 1
const retparams_firstname = 2
const retparams_surName = 3
const retparams_login = 4
const retparams_telephonenumber = 5
const retparams_emailaddress = 6
const retparams_manager = 7
dim lastDatum : lastdatum = 7
dim intDatum
 
    outputpath = "c:\ManagerList"
    outputFileName = "Manager Login.txt"
    set fso = createobject("scripting.filesystemobject")
    if not fso.folderexists(outputpath) then fso.createfolder outputpath
    set outputfile = fso.createtextfile(outputpath & "\" & outputfilename, true)
 
'    set screen = wscript.stdout 
    set dictNames = createobject("scripting.dictionary")
    on error resume next
    set olApp = createobject("Outlook.Application")
    set olNS = olApp.getnamespace("MAPI")
'    screen.writeline "Select Folder!"
    set olFolder = olNS.pickfolder
'    screen.write "Gathering email addresses "
    for each olMai in olFolder.items
'        screen.write "."
        if olmai.class = 43 then 'olmail
            if instr(olmai.senderemailaddress, "@") = 0 and olmai.senderemailaddress <> "" then
'wscript.echo right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                logname = right(olmai.senderemailaddress, len(olmai.senderemailaddress) - instrrev(olmai.senderemailaddress, "="))
                 if not dictnames.exists (lcase(logname)) then
		     dictnames.add lcase(logname), ucase(logname)
                 end if
'                dataArray = CRB_getADSInfo(logname)
'                for intdatum = 1 to ubound(dataArray)
'                    wscript.echo dataarray(intdatum)
'                next
'                wscript.echo "#################################"
            end if
        end if
    next
    dictitems = dictnames.keys
'    screen.writeline
'    screen.writeline "Processing Unique Data"
    for each dictitem in dictitems
        dataArray = CRB_getADSInfo(dictnames.item(dictitem))
        if trim(dataarray(retparams_Title)) <> "" then outputfile.write dataarray(retparams_Title) & " "
        if trim(dataarray(retparams_firstname)) <> "" then outputfile.write dataarray(retparams_firstname) & " "
        if trim(dataarray(retparams_surname)) <> "" then outputfile.write dataarray(retparams_surname)
        if trim(dataarray(retparams_login)) <> "" then outputfile.write ", (" & dataarray(retparams_login) & " - "
        if trim(dataarray(retparams_emailaddress)) <> "" then outputfile.write dataarray(retparams_emailaddress) & ")."
        outputfile.writeline
'        for intdatum = 1 to ubound(dataArray)
             wscript.echo "Processed sender " & dataarray(retparams_login)
'        next
'        wscript.echo "#################################"
    next
 
'########################################################################################
Function CRB_getADSInfo(struserid)
Dim conn
Dim sysinfo
Dim rs
Dim user
Dim strDC
 
dim retparams()
redim retparams(lastDatum)
 
    Set conn = CreateObject("ADODB.Connection")
    conn.Open "Data Source=Active Directory Provider;Provider=ADsDSOObject"
 
    set sysinfo = CreateObject("adsysteminfo")
    strDC = Right(sysinfo.UserName, Len(sysinfo.UserName) - InStr(LCase(sysinfo.UserName), "dc=") + 1)
 
    Set rs = conn.Execute("<LDAP://" & strDC & ">;(&(objectCategory=person)(objectClass=user)(sAMAccountName=" & struserid & "));adsPath;subTree")
 
    If Not rs.EOF Then
        Set user = GetObject(rs("adsPath"))
        retparams(retparams_Title) = user.title
        retparams(retparams_firstname) = user.FirstName
        retparams(retparams_surname) = user.sn
        retparams(retparams_login) = user.cn
        retparams(retparams_telephonenumber) = user.telephonenumber
        retparams(retparams_emailaddress) = user.emailAddress
        retparams(retparams_manager) = UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager,",") - 4))
'        wscript.echo user.title
'        wscript.echo user.FirstName & " " & user.sn
'        wscript.echo user.cn
'        wscript.echo user.telephonenumber
'        wscript.echo user.emailAddress
'        wscript.echo UCase(Mid(user.Manager, InStr(LCase(user.Manager), "cn=") + 3, InStr(user.Manager, ",") - 4))
    End If
    CRB_getADSInfo = retparams
Set user = Nothing
rs.Close
conn.Close
Set rs = Nothing
Set conn = Nothing
 
End Function
'#####################################################################################################

Open in new window

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Outlook

From novice to tech pro — start learning today.