asked on

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

Chris Bottomley

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

bsharath

ASKER

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....

bsharath

ASKER

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....

Chris Bottomley

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

bsharath

ASKER

Thanks Shall try and get back...

bsharath

ASKER

Hi Chris
Any help with this
https://www.experts-exchange.com/questions/23878005/Outlook-macro-that-can-compare-the-sent-and-received-mails-and-display-on-an-excel.html

Chris Bottomley

Any feedbackon this one?

Chris

bsharath

ASKER

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

bsharath

ASKER

Chris Bottomley

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

bsharath

ASKER

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 Bottomley

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

bsharath

ASKER

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 Bottomley

1. can you post the code as you have it now ... and the folder is requested a few lines later in the code.

Chris

bsharath

ASKER

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 Bottomley

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

bsharath

ASKER

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...

bsharath

ASKER

ASKER CERTIFIED SOLUTION

Chris Bottomley

membership

This solution is only available to members.

To access this solution, you must be a member of Experts Exchange.

Start Free Trial