Searching/Deleting (ADO)

Visual Basic

'Searching/Deleting Items using ADO
'This sample shows how to use Recordset to delete object after search
'
'Make reference to the ADO 2.5 library
'Make reference to Active DS Type Library

Private Sub SeachDeleteItem()

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: the user must exist for this sample to work.
strUser = "user1"

' Sample 1: Delete Appointments in 'Calendar' with subject = 'Test'
strPathOfSourceFolder = "MBX/" & strUser & "/Calendar"

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

' create the SQL query for the recordset (appointments) to be deleted
strSearchSql = "select "
strSearchSql = strSearchSql & " ""urn:schemas:mailheader:content-class"""
strSearchSql = strSearchSql & ", ""DAV:href"""
strSearchSql = strSearchSql & ", ""DAV:displayname"""
strSearchSql = strSearchSql & ", ""DAV:isfolder"""
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 ""urn:schemas:httpmail:subject"" = 'Test'"
strSearchSql = strSearchSql & " AND ""DAV:isfolder"" = false"

'Call SearchDeleteObjects(strDomainName, strLocalPathOfSourceFolder, strSearchSql)

' Sample 2: Delete the file Hello.txt from the following folder
strLocalPathOfSourceFolder = "MBX/" & strUser & "/Deleted Items"

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

' create the SQL query for the recordset (Hello.txt) to be deleted
strSearchSql = "select "
strSearchSql = strSearchSql & " ""urn:schemas:mailheader:content-class"""
strSearchSql = strSearchSql & ", ""DAV:href"""
strSearchSql = strSearchSql & ", ""DAV:displayname"""
strSearchSql = strSearchSql & ", ""DAV:isfolder"""
strSearchSql = strSearchSql & " from scope ('shallow traversal of " & Chr(34)
strSearchSql = strSearchSql & strSourceFolderUrl & """') "
strSearchSql = strSearchSql & " WHERE ""DAV:ishidden"" = false"
strSearchSql = strSearchSql & " AND ""DAV:displayname"" = 'Hello.txt'"
strSearchSql = strSearchSql & " AND ""DAV:isfolder"" = false"

'Call SearchDeleteObjects(strDomainName, strLocalPathOfSourceFolder, strSearchSql)

' Sample 3: Delete subfolder "TestFolder" under "Public Folders"
'strLocalPathOfSourceFolder = "Public Folders"
strPathOfSourceFolder = "MBX/" & strUser & "/Deleted Items"

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

' create the SQL query for the recordset (folder 'TestFolder') to be deleted
strSearchSql = "select "
strSearchSql = strSearchSql & " ""urn:schemas:mailheader:content-class"""
strSearchSql = strSearchSql & ", ""DAV:href"" "
strSearchSql = strSearchSql & ", ""DAV:displayname"""
strSearchSql = strSearchSql & ", ""DAV:isfolder"""
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:displayname"" = 'HelloFolder'"

Call SearchDeleteObjects(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 SearchDeleteObjects(strDomainName As String, strPathOfSourceFolder As String, strRestricSql 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 under which the objects are searched
strSourceFolderUrl = "file://./backofficestorage/" & _
strDomainName & "/" & strPathOfSourceFolder

' open the record
Rec.Open strSourceFolderUrl, , adModeReadWrite 'delete needs parameter adModeReadWrite

' open the recordset - a list of items
Rst.Open strRestricSql, Rec.ActiveConnection

Rst.MoveFirst
Do While Not Rst.EOF

Dim strItemUrl As String
Dim strContentClass As String

' retrieve some propertied
strItemUrl = Rst.Fields("DAV:href")
strContentClass = Rst.Fields("urn:schemas:mailheader:content-class")

'MsgBox Rst.Fields("DAV:displayname")

Rst.Delete 1

' here may make further restriction to the objects to be deleted.
' For example if searched under the Calendar folder
' dim strSubject as string
' dim strLocation as string
' strSubject = Rst.Fields("urn:schemas:httpmail:subject")
' strLocation = Rst.Fields("urn:schemas:calendar:location")
' if strSubject = "Hello" AND strLocation = "LPB-C" then
' Rst.Delete
' End If

Rst.MoveNext
Loop

' close connections
Rst.Close
Rec.Close

' clear up
Set Rst = Nothing
Set Rec = Nothing

If Err.Number = 0 Then
MsgBox "Good Job!"
End If

End Sub



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

GetDomainDNSName = strDomain
End Function