On Error Resume Next
Dim objOutlook 'As Outlook.Application
Dim Stores     'As Outlook.Stores
Dim objFolder  'As Outlook.Folder
Dim i          'As Integer
 
Set objOutlook = CreateObject("Outlook.Application")
Set Stores = objOutlook.Session.Stores
 
i = 1
Do Until i > Stores.Count
 
   If Stores(i).ExchangeStoreType = 3 Then
     If Stores(i).DisplayName <> "SharePoint Lists" then
     Set objFolder = Stores(i).GetRootFolder
   objOutlook.Session.RemoveStore objFolder
  End if
Else


      i = i + 1
End If
 
Loop