'Query the Exchange Server for users in site and selects the all free users in particular time stamp specified in Appointment Form(start and end time)
' Start Outlook -> Select Calendar - > Goto Tools -> Select Form -> Design Form
' Create Listbox from drag and drop to Form, give name ListBox1
' Create two buttons named StartSearchButton and InsertToRecipientsList
' Save You form as SearchForm
Option Explicit
Dim oShell, atb, offsetMin
Dim excgServer
Dim Status, pingStatus, DisplayName
Dim myArray(16)
'***Script will start from here when user clicks the StartSearchButton button***
Sub StartSearchButton_Click
Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").Clear()
Call MyMain()
End Sub
'***Insert the selected items in atandees list on InsertToRecipientsList button click***
Sub InsertToRecipientsList_Click
Dim Name
If Not IsNull(Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").Value) Then
If Not InStr(Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").Value, "(Free)") = 0 Then
Name = Split(Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").Value, "(Free)", -1, 1)
Else
Name = Split(Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").Value, "(Busy)", -1, 1)
End If
Item.Recipients.Add(Name(0))
Item.Save
Else
MsgBox "Please select atlease one recipients from list"
End If
End Sub
'***********Script starts here **************
Sub MyMain()
'***Define the local variables***
Dim rootDSE, conn, rs, DomainContainer, ldapStr, Str, startTime, endTime, interval, tmp1, tmp2, tmp3
Dim site
Set oShell = CreateObject("WScript.Shell")
site = oShell.ExpandEnvironmentStrings("%site%")
excgServer = "Specify Exchange server name"
'***Get the default naming context and open the connection***
Set rootDSE = GetObject("LDAP://RootDSE")
DomainContainer = rootDSE.Get("defaultNamingContext")
Set conn = CreateObject("ADODB.Connection")
conn.Provider = "ADSDSOObject"
conn.Open "ADs Provider"
'***Convert the startTime and endTime's time/date in required format***
startTime = Item.Start
endTime = Item.End
atb = "HKEY_LOCAL_MACHINE\System\CurrentControlSet\" & "Control\TimeZoneInformation\ActiveTimeBias"
offsetMin = oShell.RegRead(atb)
startTime = dateadd("n", offsetMin, startTime)
endTime = dateadd("n", offsetMin, endTime)
startTime = Format(startTime,"yyyy-mm-dd" & "T" & "hh:mm:ss" & "Z")
endTime = Format(endTime,"yyyy-mm-dd" & "T" & "hh:mm:ss" & "Z")
interval = 600
'***Decide which exchange server should be use***
pingStatus = false
Call pingExcgServer()
If pingStatus = false Then 'Find the availabe up and running Exchange server in local site
ldapStr = "<LDAP://" & DomainContainer & ">;(&(&(objectclass=computer)(memberof=CN=Exchange Domain Servers,CN=Users,DC=company,DC=com)));cn,displayname;subtree"
Set rs = conn.Execute(ldapStr)
Str = ""
While Not rs.EOF
If pingStatus = false Then
excgServer = rs.Fields(0).Value
Call pingExcgServer()
End If
rs.MoveNext
Wend
End If
ldapStr = "<LDAP://" & DomainContainer & ">;(&(objectCategory=person)(objectClass=user)(sAMAccountName=giveusersname)(homeMDB=*)(!(msExchHideFromAddressLists=TRUE)));cn,displayName;subtree"
Set rs = conn.Execute(ldapStr)
Str = ""
While Not rs.EOF
Call GetStatus(rs.Fields(0).Value, startTime, endTime, interval)
If Status = true Then
If status = "Free" Or status = "All" Then
Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").AddItem rs.Fields(1).Value & " (Free) "
End If
Else If status = "Busy" Then
Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").AddItem rs.Fields(1).Value & " (Busy) "
End If
End If
End If
rs.MoveNext
Wend
If Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").ListCount = 0 Then
Item.GetInspector.ModifiedFormPages("SearchForm").Controls("ListBox1").AddItem "No user is free in given time period"
End If
End Sub
'***********Get the status of specified strUser**************
Sub GetStatus(strUser, startTime, endTime, interval)
' Variables
Dim strUrl ' As String
Dim request ' As MSXML2.XMLHTTP
Dim doc ' As MSXML2.DOMDocument
Dim objNodeList ' As IXMLDOMNodeList
Dim objItemNode ' As IXMLDOMNode
Dim objDisplayNode ' As IXMLDOMNode
Dim objFBNode ' As IXMLDOMNode
Status = false
strUrl="http://" & excgServer & "/public/?cmd=freebusy" & _
"&start=" & startTime & _
"&end=" & endTime & _
"&interval=" & interval & _
"&u=SMTP:" & strUser
' Initialize the XMLHTTP object.
set request=createobject("Msxml2.XMLHTTP")
' Open the request object with the GET method and
' specify that it will be sent asynchronously.
request.open "GET", strUrl, false
' Set the Content-Type header.
request.setRequestHeader "Content-Type", "text/xml"
' Set the Content-Length header.
request.setRequestHeader "Content-Length", 0
' Set the Accept-language header.
request.setRequestHeader "Accept-Language", "en-us"
' Send the GET method request.
request.send ""
' The request was successful.
If 200 = request.status Then
' Uncomment this line to see the XML response.
' wscript.echo request.responsetext
' Create the DOM document.
Set doc=createobject("msxml2.domdocument")
' Load the XML response body.
If doc.loadXml(request.ResponseText) Then
Set objNodeList=doc.selectNodes("//a:item")
' Iterate through the WM:item nodes.
For Each objItemNode In objNodeList
' Use an XPath query to get the WM:displayname node
' from the WM:item node.
set objDisplayNode = objItemNode.selectSingleNode("a:displayname")
' Use an XPath query to get the WM:fbdata node
' from the WM:item node.
set objFBNode = objItemNode.selectSingleNode("a:fbdata")
' Display free/busy information.
'wscript.echo "Display name: " & objDisplayNode.Text
'wscript.echo "Free/busy data: " & objFBNode.Text
DisplayName = objDisplayNode.Text
If objFBNode.Text = 0 Then
Status = true
End If
Next
End If
Else
MsgBox request.status & " " & request.statustext
End if
' Clean up.
Set request = nothing
Set doc = nothing
End Sub
Function Format(vExpression, sFormat)
Dim fmt, rs
set fmt = CreateObject("MSSTDFMT.StdDataFormat")
fmt.Format = sFormat
set rs = CreateObject("ADODB.Recordset")
rs.Fields.Append "fldExpression", 12 ' adVariant
rs.Open
rs.AddNew
set rs("fldExpression").DataFormat = fmt
rs("fldExpression").Value = vExpression
Format = rs("fldExpression").Value
rs.close: Set rs = Nothing: Set fmt = Nothing
End Function
Function ereg(strOriginalString, strPattern, varIgnoreCase)
' Function matches pattern, returns true or false
' varIgnoreCase must be TRUE (match is case insensitive) or FALSE (match is case sensitive)
dim objRegExp : set objRegExp = new RegExp
with objRegExp
.Pattern = strPattern
.IgnoreCase = varIgnoreCase
.Global = True
end with
ereg = objRegExp.test(strOriginalString)
set objRegExp = nothing
End Function
Function pingExcgServer()
dim objPing, objRetStatus
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}").ExecQuery("select * from Win32_PingStatus where address = '" & excgServer & "'")
For Each objRetStatus in objPing
If IsNull(objRetStatus.StatusCode) or objRetStatus.StatusCode<>0 Then
pingStatus = False
Else
pingStatus = True
End If
Next
End Function
Regards,
Megha