Modifying Objects (CDOEX and ADO)
Topic Last Modified: 2006-06-12
Example
Visual Basic
Note
The following example uses a file URL with the Exchange OLE DB (ExOLEDB) provider. The ExOLEDB provider also supports The HTTP: URL Scheme. Using The HTTP: URL Scheme allows both client and server applications to use a single URL scheme.
'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