Макрос в outlook

[shalun]

Добрый день.
Помогите, пжлста - нужна одноразовая прога.

В Outlook есть более 1000 контактов, записаны они абы-как.
Имя: Иван Иваныч Иванов
Хранить как: Иванов, Иван Иванович
тел.1. +7 495 123-45-67
тел.2. +7 495 123-45-67
другой +7 916 123-45-67
тел.3. +7 495 123-45-67*123

задача:
1. Чтобы "хранить как" было везде Имя Отчество Фамилия (в настройках по умолчанию раньше стояло Ф,ИО => все перебирать руками анриал)
2. все 495, 916, и т.п. (коды городов) взять в скобки
3. убрать минусы в номерах телефонов
4. удалить "*" и все что после нее перенести в "добавочный номер"
5. все телефоны "другой" перенести в разряд "сотовый"

[RayShade]

Поищи в гугле что нибудь типа outlook contacts organizer

[shalun]

уже порыскал - нашел то, что нужно, есть еще несколько нюансов.

кому интересно:
Function NewNumber(OldNumber As String) As String
NewNumber = Replace(OldNumber, "+7 495", "+7 (495)")
`NewNumber = Replace(OldNumber, "+7 499", "+7 (499)")
`NewNumber = Replace(OldNumber, "+7 901", "+7 (901)")
`NewNumber = Replace(OldNumber, "+7 903", "+7 (903)")
`NewNumber = Replace(OldNumber, "+7 910", "+7 (910)")
`NewNumber = Replace(OldNumber, "+7 916", "+7 (916)")
`NewNumber = Replace(OldNumber, "+7 926", "+7 (926)")
`NewNumber = Replace(OldNumber, "+7 963", "+7 (963)")
`NewNumber = Replace(OldNumber, "+7 812", "+7 (812)")
`NewNumber = Replace(OldNumber, "+7 10 375 17", "+375 (17)")
`NewNumber = Replace(OldNumber, "+7 4922", "+7 (4922)")
`NewNumber = Replace(OldNumber, "*", " доб. ")
`NewNumber = Replace(OldNumber, "+7 48762", "+7 (48762)")
`NewNumber = Replace(OldNumber, "+7 4912", "+7 (4912)")
End Function

Sub ChangePhoneNumbers()
Dim myOlApp As Outlook.Application
Dim myNameSpace As Outlook.NameSpace
Dim myContacts As Outlook.Items
Dim myItem As Object
Dim myPhone As ItemProperty

Set myOlApp = CreateObject("Outlook.Application")
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myContacts = _
myNameSpace.GetDefaultFolder(olFolderContacts).Items

For Each myItem In myContacts
If (myItem.Class = olContact) Then
myItem.Display

For Each myPhone In myItem.ItemProperties
If (myPhone.Name Like "*phone*") Or _
(myPhone.Name Like "*fax*") Then
myPhone.Value = NewNumber(myPhone.Value)
End If
Next

myItem.Close olSave
End If
Next
End Sub

теперь нужно разобраться почему не меняются номера в "факс рабочий" и как "хранить как" изменить.
Я в макросах не рублю совсем аутлуковских - придется разбираться(

[RayShade]

Во первых это крайне тупой код. Его автору бы, поучить матчасть и тогда он скорее всего бы понял, что вот это

Код: Выделить всё

Function NewNumber(OldNumber As String) As String
NewNumber = Replace(OldNumber, "+7 495", "+7 (495)")
`NewNumber = Replace(OldNumber, "+7 499", "+7 (499)")
`NewNumber = Replace(OldNumber, "+7 901", "+7 (901)")
`NewNumber = Replace(OldNumber, "+7 903", "+7 (903)")
`NewNumber = Replace(OldNumber, "+7 910", "+7 (910)")
`NewNumber = Replace(OldNumber, "+7 916", "+7 (916)")
`NewNumber = Replace(OldNumber, "+7 926", "+7 (926)")
`NewNumber = Replace(OldNumber, "+7 963", "+7 (963)")
`NewNumber = Replace(OldNumber, "+7 812", "+7 (812)")
`NewNumber = Replace(OldNumber, "+7 10 375 17", "+375 (17)")
`NewNumber = Replace(OldNumber, "+7 4922", "+7 (4922)")
`NewNumber = Replace(OldNumber, "*", " доб. ")
`NewNumber = Replace(OldNumber, "+7 48762", "+7 (48762)")
`NewNumber = Replace(OldNumber, "+7 4912", "+7 (4912)")
End Function

Осущетсвляется всего навсего 1 regexp типа

Код: Выделить всё

Search:
\+([0-9]){1}\s+?([0-9]){1,5}
Replace:
+$1 ($2)


Который покрывает 99% переделки телефонных кодов.



Но это не самое главное Отправляя в гугль, я собственно советовал поискать уже готовую программу, которая это все делает Их же уже написан миллион.