PendingCompletion

HTC Tags aus Kontakten entfernen

Sub HTCbGone()
   Dim objContactsFolder As Outlook.MAPIFolder
   Dim objContacts As Outlook.Items
   Dim objContact As <a title="See also Share Point 2010 Suche - keine Ergebnisse bei "nicht Admin" Benutzern" href="http://www.pendingcompletion.de/7/">Object</a>
   Dim StartPos As Integer
   Dim EndPos As Integer
   Dim iCount As Integer

   ' Specify with which contact folder to work
   Set objContactsFolder = _
      Session.GetDefaultFolder(olFolderContacts)
   Set objContacts = objContactsFolder.Items

   iCount = 0

   ' Process the changes
   For Each objContact In objContacts
      If TypeName(objContact) = "ContactItem" Then
         StartPos = InStr(objContact.Body, "&lt;HTCData&gt;")
         EndPos = InStr(objContact.Body, "&lt;/HTCData&gt;") + 10
         If StartPos &gt; 0 Then
            If StartPos = 1 Then
                If Len(EndPos) &gt; EndPos + 1 Then
                    objContact.Body = Mid(objContact.Body, EndPos + 1)
                Else
                    objContact.Body = ""
                End If
            Else
                If Len(EndPos) &gt; EndPos + 1 Then
                    objContact.Body = Left(objContact.Body, StartPos = 1)
                Else
                    objContact.Body = Left(objContact.Body, StartPos - 1) &amp; Mid(objContact.Body, EndPos + 1)
                End If
            End If
            iCount = iCount + 1
            objContact.Save

         End If
      End If
   Next

   ' Display the results
   MsgBox "Number of contacts updated:" &amp; Str$(iCount), , _
      "HTCbGone Finished"

   ' Clean up
   Set objContact = Nothing
   Set objContacts = Nothing
   Set objContactsFolder = Nothing

End Sub

Quelle: http://forum.xda-developers.com/showthread.php?t=737014