• Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 307
  • Last Modified:

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
0
bsharath
Asked:
bsharath
  • 11
  • 8
1 Solution
 
Chris BottomleyCommented:
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
0
 
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....
0
 
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....
0
Transaction-level recovery for Oracle database

Veeam Explore for Oracle delivers low RTOs and RPOs with agentless transaction log backup and transaction-level recovery of Oracle databases. You can restore the database to a precise point in time, even to a specific transaction.

 
Chris BottomleyCommented:
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

0
 
bsharathAuthor Commented:
Thanks Shall try and get back...
0
 
Chris BottomleyCommented:
Any feedbackon this one?

Chris
0
 
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  
---------------------------
0
 
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  
---------------------------
0
 
Chris BottomleyCommented:
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

0
 
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  
---------------------------
0
 
Chris BottomleyCommented:
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
0
 
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?
0
 
Chris BottomleyCommented:
1. can you post the code as you have it now ... and the folder is requested a few lines later in the code.

Chris
0
 
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

0
 
Chris BottomleyCommented:
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

0
 
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...
0
 
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...
0
 
Chris BottomleyCommented:
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

0

Featured Post

Fill in the form and get your FREE NFR key NOW!

Veeam is happy to provide a FREE NFR server license to certified engineers, trainers, and bloggers.  It allows for the non‑production use of Veeam Agent for Microsoft Windows. This license is valid for five workstations and two servers.

  • 11
  • 8
Tackle projects and never again get stuck behind a technical roadblock.
Join Now