Outlook Form Programming : Search the free/busy status of users and get the free users in time specified in appointment form(start time and end time)

I did the lot of research and customized outlook form and written this VBA script to get the all users in local site and get the free/busy status from exchanges server and display all users with their status during time specified in Appointment form (start time and end time) in ListBox. Let me know if you find any difficulties in this.

'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

By Perry    Popularity  (2890 Views)