Modifying Objects (CDOEX and ADO)

Visual Basic

'Modify Object using CDOEx and ADO
' This sample shows how to do the following after search
' - Change folder name
' - Modify appointments
' - Modify contacts
'
' Make reference to  CDO for Exchange 2000 and ADO 2.5 libraries
' Make reference to Active DS Typy Library

Private Sub ModifyObject()

On Error GoTo Errorhandler

Dim strDomainName As String
Dim strUser As String

Dim strLocalPathOfSourceFolder As String
Dim strSourceFolderUrl As String
Dim strSearchSql As String

' specify the domain and user
strDomainName = GetDomainDNSName()

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

' Sample 1: Modify Appointments in 'Calendar'
strLocalPathOfSourceFolder = "MBX/" & strUser & "/Calendar"

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

' 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:calendar:title"""
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 ModifyObjects(strDomainName, _
strLocalPathOfSourceFolder, _
strSearchSql)

' Sample 2: Modify Contacts in 'Ccontacts'
strLocalPathOfSourceFolder = "MBX/" & strUser & "/Contacts"

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

' 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 & ", ""urn:schemas:Contacts:Title""" '
strSearchSql = strSearchSql & ", ""DAV:isfolder"""
strSearchSql = strSearchSql & ", ""DAV:iscollection"""
strSearchSql = strSearchSql & ", ""urn:schemas:calendar:title"""
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 ModifyObjects(strDomainName, _
strLocalPathOfSourceFolder, _
strSearchSql)

' Sample 3: Change for tje folder named "TestFolder" of the subfolder of 'MBX/Outbox' to "MidifiedFolder"
strLocalPathOfSourceFolder = "MBX/" & strUser & "/Outbox"

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

' 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"
strSearchSql = strSearchSql & " AND ""DAV:isfolder"" = true"
strSearchSql = strSearchSql & " AND ""DAV:iscollection"" = true"
strSearchSql = strSearchSql & " AND ""DAV:displayname"" = 'TestFolder'"

Call ModifyObjects(strDomainName, _
strLocalPathOfSourceFolder, _
strSearchSql)

GoTo Ending

Errorhandler:

   ' Implement custom error handling here.
   Debug.Print "Error: " + Str(Err.Number) + " " + Err.Description
   Err.Clear

Ending:
   Unload Me
End Sub


Private Sub ModifyObjects(strDomainName As String, _
strLocalPathOfSourceFolder As String, _
strRestrictSql As String)

Dim Rec As New ADODB.Record
Dim Rst As New ADODB.Recordset
Dim strSourceFolderUrl As String

' set the strURL to the location of the folders
strSourceFolderUrl = "file://./backofficestorage/" & _
strDomainName & "/" & strLocalPathOfSourceFolder

' open record
Rec.Open strSourceFolderUrl, , adModeReadWrite 'Modify needs parameter adModeReadWrite

If Rec.State = adStateOpen Then
Debug.Print "Rec opened"
End If

' open recordset, a list of objects
Rst.Open strRestrictSql, Rec.ActiveConnection ', adOpenForwardOnly, adLockOptimistic

If Rst.RecordCount = 0 Then
   Debug.Print "No searched objects found!"

   ' Clean up.
   Rec.Close
   Rst.Close
   Set Rec = Nothing
   Set Rst = Nothing
Exit Sub
End If


' now found some objects
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")

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

' change folder name using 'Move' from Record
Dim tempRec As New ADODB.Record
Dim strFolderName As String ' new folder name
strFolderName = "NameChangedFolder" ' New folder name

' open the record
tempRec.Open strObjectUrl, , adModeReadWrite 'Modify needs parameter adModeReadWrite
tempRec.MoveRecord strObjectUrl, strSourceFolderUrl & "/" & strFolderName

' close the temp reccord
tempRec.Close

Else

Select Case strContentClass
Case "urn:content-classes:message"
Dim iMessage As New CDO.Message
iMessage.DataSource.Open strObjectUrl, Rec.ActiveConnection, adModeReadWrite

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, Rec.ActiveConnection, adModeReadWrite

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

'Modify property directly
iPerson.Title = "Support Engineer"
iPerson.DataSource.Save

'Modify property using Fields
iPerson.Fields("urn:schemas:contacts:title") = "Manager"
iPerson.Fields.Update
iPerson.DataSource.Save

Set iPerson = Nothing

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

Debug.Print "Appointment" & vbLf & _
"Subject: " & iAppointment.Subject & vbLf & _
"Location: " & iAppointment.Location & vbLf & _
"StartTime: " & iAppointment.StartTime & vbLf & _
"EndTime: " & iAppointment.EndTime & vbLf & vbLf

' Modify some properties directly
iAppointment.Subject = "Subject changed"

' modify property using Fields
iAppointment.Fields("urn:schemas:calendar:location") = "Issaqua"
iAppointment.Fields.Update
iAppointment.DataSource.Save

Set iAppointment = Nothing

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

End If

Rst.MoveNext
Loop

' close connections
Rst.Close
Rec.Close

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