Searching/Listing Items (ADO)

Visual Basic

'Searching/Listing Items Using ADO
'This sample shows how to search objects.
'
'Make reference to the ADO 2.5 library.
'Make reference to Active DS Type Library.
Private Sub SearchItems()

   On Error GoTo Errorhandler

   Dim strDomainName As String
   Dim strUser As String

   Dim strPathOfSourceFolder As String
   Dim strSourceFolderUrl As String
   Dim strSearchSql As String

   ' Specify the domain and user.
   strDomainName = GetDomainDNSName()

   ' Note: the user must exist for this sample to work.
   strUser = "user1"

   ' Sample 1: List Appointments in Calendar
   strPathOfSourceFolder = "MBX/" & strUser & "/Calendar"

   strSourceFolderUrl = "file://./backofficestorage/" & _
   strDomainName & "/" & strPathOfSourceFolder

   ' Create the SQL query for the recordset (appointments).
   strSearchSql = "select "
   strSearchSql = strSearchSql & " ""urn:schemas:mailheader:content-class"""
   strSearchSql = strSearchSql & ", ""DAV:href"""
   strSearchSql = strSearchSql & ", ""DAV:displayname"""
   strSearchSql = strSearchSql & ", ""DAV:isfolder"""
   strSearchSql = strSearchSql & ", ""DAV:iscollection"""
   strSearchSql = strSearchSql & ", ""urn:schemas:httpmail:subject"""
   strSearchSql = strSearchSql & " from scope ('shallow traversal of " & Chr(34)
   strSearchSql = strSearchSql & strSourceFolderUrl & """') "
   strSearchSql = strSearchSql & " WHERE ""DAV:ishidden"" = false"
   strSearchSql = strSearchSql & " AND ""DAV:isfolder"" = false"

   Call SearchListObjects(strDomainName, strPathOfSourceFolder, strSearchSql)


   ' Sample 2: List Contacts in Ccontacts.
   strPathOfSourceFolder = "MBX/" & strUser & "/Contacts"

   strSourceFolderUrl = "file://./backofficestorage/" & _
   strDomainName & "/" & strPathOfSourceFolder

   ' Create the SQL query for the recordset (appointments).
   strSearchSql = "select "
   strSearchSql = strSearchSql & " ""urn:schemas:mailheader:content-class"""
   strSearchSql = strSearchSql & ", ""DAV:href"""
   strSearchSql = strSearchSql & ", ""DAV:displayname"""
   strSearchSql = strSearchSql & ", ""DAV:isfolder"""
   strSearchSql = strSearchSql & ", ""DAV:iscollection"""
   strSearchSql = strSearchSql & ", ""urn:schemas:httpmail:subject"""
   strSearchSql = strSearchSql & " from scope ('shallow traversal of " & Chr(34)
   strSearchSql = strSearchSql & strSourceFolderUrl & """') "
   strSearchSql = strSearchSql & " WHERE ""DAV:ishidden"" = false"
   strSearchSql = strSearchSql & " AND ""DAV:isfolder"" = false"

   ' Call SearchListObjects(strDomainName, strPathOfSourceFolder, strSearchSql).


   ' Sample 3: List Travel all subfolders of MBX under the user
   'strPathOfSourceFolder = "MBX/" & strUser

   strPathOfSourceFolder = "MBX/" & strUser & "/Deleted Items"

   strSourceFolderUrl = "file://./backofficestorage/" & _
   strDomainName & "/" & strPathOfSourceFolder

   ' Create the SQL query for the recordset (appointments).
   strSearchSql = "select "
   strSearchSql = strSearchSql & " ""urn:schemas:mailheader:content-class"""
   strSearchSql = strSearchSql & ", ""DAV:href"""
   strSearchSql = strSearchSql & ", ""DAV:displayname"""
   strSearchSql = strSearchSql & ", ""DAV:isfolder"""
   strSearchSql = strSearchSql & ", ""DAV:iscollection"""
   strSearchSql = strSearchSql & " from scope ('shallow traversal of " & Chr(34)
   strSearchSql = strSearchSql & strSourceFolderUrl & """') "
   strSearchSql = strSearchSql & " WHERE ""DAV:ishidden"" = false"

   ' This can be omitted.
   strSearchSql = strSearchSql & " AND ""DAV:isfolder"" = true"
   strSearchSql = strSearchSql & " AND ""DAV:iscollection"" = true"

   Call SearchListObjects(strDomainName, strPathOfSourceFolder, strSearchSql)

   GoTo Ending

   Errorhandler:

   Debug.Print "Error: " + Str(Err.Number) + " " + Err.Description
   Err.Clear

   Ending:

End Sub


Private Sub SearchListObjects(strDomainName As String, strLocalPathOfSourceFolder As String, strSearchSql As String)
   Dim Rec As New ADODB.Record
   Dim Rst As New ADODB.Recordset
   Dim strSourceFolderUrl As String

   ' Set the URL to the location of the folder.
   strSourceFolderUrl = "file://./backofficestorage/" & _
   strDomainName & "/" & strLocalPathOfSourceFolder

   ' Open the record.
   Rec.Open strSourceFolderUrl, , adModeReadWrite 'Move needs parameter adModeReadWrite

   ' Open recordset - a list of objects.
   Rst.Open strSearchSql, Rec.ActiveConnection

   ' Check to see if any objects were found.
   If Rst.RecordCount = 0 Then
      Debug.Print "No objects found!"
      Exit Sub
   End If

   ' Some objects have been found.
   Rst.MoveFirst
   Do While Not Rst.EOF

   Dim strObjectUrl As String
   Dim strContentClass As String

   ' Retrieve some properties.
   strObjectUrl = Rst.Fields("DAV:href")
   strContentClass = Rst.Fields("urn:schemas:mailheader:content-class")
   Debug.Print "ContectClass : " & strContentClass

   If Rst.Fields("DAV:iscollection") = True Then
      Debug.Print "FolderName : " & Rst.Fields("DAV:displayname")

      ' Retrieve the Folder Type property.
      Dim iFolder As New CDO.Folder
      iFolder.DataSource.Open strObjectUrl

      Debug.Print "FolderType : " & iFolder.Fields("https://schemas.microsoft.com/exchange/outlookfolderclass") & vbLf

      Set iFolder = Nothing
   Else
      Select Case strContentClass
         Case "urn:content-classes:message"
            Dim iMessage As New CDO.Message
            iMessage.DataSource.Open strObjectUrl

            ' Display some properties.
            Debug.Print "Message" & vbLf & _
            "Sender: " & iMessage.Sender & vbLf & _
            "Subject: " & iMessage.Subject & vbLf & _
            "DateRecdeived: " & iMessage.ReceivedTime & vbLf & vbLf

            Set iMessage = Nothing

         Case "urn:content-classes:person"
            Dim iPerson As New CDO.Person
            iPerson.DataSource.Open strObjectUrl

            ' Display some properties.
            Debug.Print "Person" & vbLf & _
            "First Name: " & iPerson.FirstName & vbLf & _
            "Last Name: " & iPerson.LastName & vbLf & _
            "Title: " & iPerson.Title & vbLf & _
            "Company: " & iPerson.Company & vbLf & vbLf

            Set iPerson = Nothing

         Case "urn:content-classes:appointment"
            Dim iAppointment As New CDO.Appointment
            iAppointment.DataSource.Open strObjectUrl

            ' Display some properties.
            Debug.Print "Appointment" & vbLf & _
            "Subject: " & iAppointment.Subject & vbLf & _
            "Location: " & iAppointment.Location & vbLf & _
            "StartTime: " & iAppointment.StartTime & vbLf & _
            "EndTime: " & iAppointment.EndTime & vbLf & vbLf

            Set iAppointment = Nothing

         Case Else
            Debug.Print "The case :" & strContentClass & " is not included here"
      End Select

   End If

   Rst.MoveNext
   Loop

   ' Close the connections.
   Rst.Close
   Rec.Close

   ' Clean up.
   Set Rst = Nothing
   Set Rec = Nothing

End Sub


Private Function GetDomainDNSName() As String
   Dim Info As New ADSystemInfo
   Dim strDomain As String
   strDomain = Info.DomainDNSName

   GetDomainDNSName = strDomain
End Function