Changing an Existing Contact with CDOEX (Visual Basic)

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.

'Changing an Existing Contact with ADO and CDOEx
'
'Reference the project with
' - Active Directory Type Library
' - Microsoft CDO for Exchange 2000 Library
' - Microsoft ActiveX Data Objects 2.5 Library

Private Sub ChangeContact()

Dim oRec As ADODB.Record
Dim sURL As String
Dim sSQL As String
Dim oRst As ADODB.Recordset
Dim sHREF As String
Dim sDomainName As String
Dim sLocalPath As String
Dim sMailBox As String
Dim sChangeName As String
Dim bFound As Boolean
Dim oAdSysInfo As ActiveDs.ADSystemInfo
Set oAdSysInfo = CreateObject("ADsystemInfo")
sDomainName = oAdSysInfo.DomainDNSName



sMailBox = "user1"

' Specify a URL to the contacts folder or a contact item.
sLocalPath = "MBX/" & sMailBox & "/contacts"

' sLocalPath = "MBX\administrator\contacts"
sChangeName = "user2"
Set oRec = CreateObject("ADODB.Record")
Set oRst = CreateObject("ADODB.Recordset")

sURL = "file://./backofficestorage/" & sDomainName & "/" & sLocalPath
oRec.Open sURL

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

' Open the recordset, a list of folders and/or items.
oRst.Open sSQL, oRec.ActiveConnection
bFound = False
Do While Not oRst.EOF
    Dim oPer As New CDO.Person
    Dim sRecordSource As String
    Dim sNameToChange As String
    sRecordSource = oRst.Fields("DAV:href")
    oPer.DataSource.Open sRecordSource, , adModeReadWrite
    sNameToChange = oPer.FirstName
    sNameToChange = sNameToChange & IIf((oPer.MiddleName = ""), " ", " " & oPer.MiddleName & " ")
    sNameToChange = sNameToChange & oPer.LastName
    If Trim(UCase(sNameToChange)) = UCase(sChangeName) Then
        bFound = True
Exit Do
End If
oRst.MoveNext
Set oPer = Nothing
Loop
If Not bFound Then
MsgBox sChangeName & ": No such contact was found. Check the name and try again."
Else

' The contact was found. You can change the contact attributes on the person object itself.
oPer.Company = "Adventure Works"
oPer.email = "someone@adventure-works.com"
oPer.WorkStreet = "One Main Street"
oPer.WorkCity = "Redmond"
oPer.WorkCountry = "USA"
oPer.WorkPostalCode = "98052"

' Some additional properties are listed on the Exchange store schema, which can be accessed using the following fields collection.

' The named constant for billing information is not available.
oPer.Fields("urn:schemas:contacts:billinginformation") = "Sample Billing Information"
oPer.Fields("urn:schemas:contacts:businesshomepage") = "https://www.adventure-works.com"
oPer.Fields("urn:schemas:contacts:spousecn") = "Spouse Name" 'Spouse Common Name
' Update the fields collection.
oPer.Fields.Update
oPer.DataSource.Save
End If
Set oPer = Nothing
End Sub

Sub Main()

 Call ChangeContact

End Sub