04Ноя
как убрать из Outlook HTCData
04
Ноя
Недавно поменял телефон, поэтому возникла необходимость убрать из всех контактов в Outlook заметки вида:
<HTCData><!– Please do not modify –>
<Facebook>id:XXXXXXXXXX/friendof:XXXXXXXXXX</Facebook>
</HTCData>
Для решения этой проблемы можно воспользоваться макросом.
Sub HTCbGone()
Dim objContactsFolder As Outlook.MAPIFolder
Dim objContacts As Outlook.Items
Dim objContact As Object
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, "")
EndPos = InStr(objContact.Body, "") + 10
If StartPos > 0 Then
If StartPos = 1 Then
If Len(EndPos) > EndPos + 1 Then
objContact.Body = Mid(objContact.Body, EndPos + 1)
Else
objContact.Body = ""
End If
Else
If Len(EndPos) > EndPos + 1 Then
objContact.Body = Left(objContact.Body, StartPos = 1)
Else
objContact.Body = Left(objContact.Body, StartPos - 1) & 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:" & Str$(iCount), , _
"HTCbGone Finished"
' Clean up
Set objContact = Nothing
Set objContacts = Nothing
Set objContactsFolder = Nothing
End Sub
Dim objContactsFolder As Outlook.MAPIFolder
Dim objContacts As Outlook.Items
Dim objContact As Object
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, "")
EndPos = InStr(objContact.Body, "") + 10
If StartPos > 0 Then
If StartPos = 1 Then
If Len(EndPos) > EndPos + 1 Then
objContact.Body = Mid(objContact.Body, EndPos + 1)
Else
objContact.Body = ""
End If
Else
If Len(EndPos) > EndPos + 1 Then
objContact.Body = Left(objContact.Body, StartPos = 1)
Else
objContact.Body = Left(objContact.Body, StartPos - 1) & 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:" & Str$(iCount), , _
"HTCbGone Finished"
' Clean up
Set objContact = Nothing
Set objContacts = Nothing
Set objContactsFolder = Nothing
End Sub
Для его выполнения октройте Outlook, нажмите клавишу [Alt + F8]. Создайте новый макрос HTCbGone и вставить вышеприведенный код. Осталось только запустить.
Если у вас есть еще вложенный папки контактов, то для каждой папке, которую надо обработать, макрос надо слегка модифицировать.
Set objContactsFolder = _
Session.GetDefaultFolder(olFolderContacts).Folders("ИМЯ ВЛОЖЕННОЙ ПАПКИ")
Session.GetDefaultFolder(olFolderContacts).Folders("ИМЯ ВЛОЖЕННОЙ ПАПКИ")
Вам понравился этот пост?
Почему бы не оставить комментарий ниже или не подписаться на мой feed?
Комментарии
Еще нет комментариев.
Оставить комментарий