' outlook_add_folder_v1.vbs
'
' Check if user has Exchange Account by Peter  Verijke - (c) 2003 Computech
' http://www.codeproject.com/KB/vbscript/ExchangeMailBox.aspx?msg=946994
'
' This script checks if a user has an email  account, then checks a registry key to see if a Outlook folder has
' already been created. If it has already been  created, the script exits, otherwise the folder is created and
' the needed registry key is created as well.
'
' Logic in a nutshell:
' Does user have an Exchange account?
'      Yes
'           Does the registry key exist?
'                Yes
'                     Exit
'                No
'                     Create  folder in Outlook
'                     Create  registry key
'                     Exit
'      No
'           Exit

Const HKEY_CLASSES_ROOT = &H80000000
Const HKEY_CURRENT_USER = &H80000001
Const HKEY_LOCAL_MACHINE = &H80000002
Const HKEY_USERS = &H80000003
Const HKEY_CURRENT_CONFIG = &H80000005
 
Dim strKeyPath
Dim strValueName
Dim strValue
Dim strValueCurrent
Dim arrValues
Dim intValue
Dim ArgObj
Dim WshShell ' as object
Dim objEnv ' as collection
Dim objUser 'As IADsUser
Dim objMailbox 'As CDOEXM.IMailboxStore
Dim sUserLDAPName 'As String
Dim DCServer 'As String
Dim olkApp
Dim olkSession
Dim olkParentFolder
Dim olkNewFolder
Dim strComputer
Dim objRegistry
 
On Error Resume Next
 
strComputer = "."
Set objRegistry = GetObject("winmgmts:\\" & strComputer & "\root\default:StdRegProv")
 
' Get the Arguments object
Set ArgObj = WScript.Arguments
 
If ArgObj.Count < 1 Then
     Set WshShell = WScript.CreateObject("WScript.Shell")
     Set objEnv = WshShell.Environment("PROCESS")
     sUserName = objEnv("USERNAME")
Else
     sUserName = UCase(ArgObj(0))
End If
 
' Define your AD Domain Controller
DCServer = "dc01.domain.local"
 
sUserLDAPName = QueryActiveDirectory(sUserName)
Set objUser = GetObject("LDAP://" & DCServer + "/" & sUserLDAPName)
Set objMailbox = objUser
 
'check if user is mailbox enabled
If objMailbox.HomeMDB = "" Then
     'This user does not have a Exchange mailbox
     WScript.Quit 1
Else
     'This user does have an Exchange mailbox
     ' Define your registry keys and values
     strKeyPath = "settings\software\outlook"
     strValueName = "mail_archive_folder_created"
     strValue = "1"
 
     ' Get the current value of the key if it exists and put it into  strValueCurrent
     objRegistry.GetStringValue HKEY_CURRENT_USER,strKeyPath,strValueName,strValueCurrent
 
     ' Check if the value of the key is null, and if it is create the folder  in Outlook and also create the new
     ' registry key to prevent it from being recreated over and over again.
     If (IsNull(strValueCurrent) = True) Then
          Set olkApp = CreateObject("Outlook.Application")
          Set olkSession = olkApp.GetNamespace("MAPI")
          olkSession.Logon "Outlook"
          'Change the parent folder name and path on the following line
          Set olkParentFolder = olkSession.GetDefaultFolder(6).Parent
          'Change the new folder's name on the following line
          Set olkNewFolder = olkParentFolder.Folders.Add("Mail Archive")
          'Change the URL on the following line
          olkNewFolder.WebViewURL = "http://server.domain.local/archive.php"
          olkNewFolder.WebViewOn = True
          olkSession.Logoff
 
          'Create your registry key
          objRegistry.CreateKey HKEY_CURRENT_USER,strKeyPath
          'Set your registry value
          objRegistry.SetStringValue HKEY_CURRENT_USER,strKeyPath,strValueName,strValue
     End If
     WScript.Quit 0
End If
 
Public Function QueryActiveDirectory(sUserName)
'Function:      QueryActiveDirectory
'Purpose:       Search the Active Directory's Global Catalog for users
'Parameters:    UserName - user to search for
'Return:        The user's distinguished name

Dim oAD 'As IADs
Dim oGlobalCatalog 'As IADs
Dim oRecordSet 'As Recordset
Dim oConnection 'As New Connection
Dim strADsPath 'As String
Dim strQuery 'As String
Dim strUPN 'As String

set oRecordSet = CreateObject("ADODB.Recordset")
set oConnection = CreateObject("ADODB.Connection")
 
'Determine the global catalog path
Set oAD = GetObject("GC:")
For Each oGlobalCatalog In oAD
strADsPath = oGlobalCatalog.AdsPath
Next
 
'Initialize the ADO object
oConnection.Provider = "ADsDSOObject"
 
'The ADSI OLE-DB provider
oConnection.Open "ADs Provider"
 
'Create the search string
strQuery = "<" & strADsPath & _
">;(&(objectClass=user)(objectCategory=person)(samaccountName=" &  _
sUserName & "));userPrincipalName,cn,distinguishedName;subtree"
 
'Execute the query
Set oRecordSet = oConnection.Execute(strQuery)
If oRecordSet.EOF And oRecordSet.BOF Then
     'An empty recordset was returned
     QueryActiveDirectory = "Not Found"
Else    'Records were found; loop through them
     While Not oRecordSet.EOF
     QueryActiveDirectory = oRecordSet.Fields("distinguishedName")
     oRecordSet.MoveNext
     Wend
End If
 
End Function