Deleting an Existing Contact with CDOEX (Visual Basic)

Visual Basic

' Deleting an Existing Contact with CDOEx

Sub DeleteContact(sDeleteName As String, sMailbox As String)

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 sDeleteName As String
Dim bFound As Boolean
Dim oAdSysInfo As ActiveDs.ADSystemInfo

Set oAdSysInfo = CreateObject("ADsystemInfo")
sDomainName = oAdSysInfo.DomainDNSName

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

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 sNameToDelete As String
    sRecordSource = oRst.Fields("DAV:href")
    oPer.DataSource.Open sRecordSource, , adModeReadWrite
    sNameToDelete = oPer.FirstName
    sNameToDelete = sNameToDelete & IIf((oPer.MiddleName = ""), " ", " " & oPer.MiddleName & " ")
    sNameToDelete = sNameToDelete & oPer.LastName
    If Trim(UCase(sNameToDelete)) = UCase(sDeleteName) Then
        bFound = True
        oRst.Delete
        Exit Do
    End If
    oRst.MoveNext
    Set oPer = Nothing
Loop
If Not bFound Then
    Debug.Print sDeleteName & ": No such contact found to delete. Please check the name again."
End If
End Sub