Dodanie +48 i zmiana formatu telefonów w książce adresowej
by vbatools on Jun.11, 2011, under Outlook, Porady
Dzięki programowaniu można zamienić format kontaktów w MS Outlook, tak aby podczas importu ich do telefonów GSM zyskały na czytelności. Telefon nie stwarza trudności podczas gdy pozostawiamy zapis numeru zawierającego nawias i spację. Myślę tutaj o formacie (xxx) xxxxxx. Jeśli dołożymy do tego +48 to wszystkie rozmowy zostaną rozpoznane automatycznie (nawet wtedy, gdy operator doklei taki prefix) jeśli nasz rozmówca zadzwoni z z zagranicy.
Przedstawiona poniżej procedura daje możliwość sprawdzenia czy ilość znaków na danym numerze telefonu jest zgodna z normą (brak prowadzonych opisów czy numerów wew do numeru) i zmieni je na format +48 (xx) xxxxxxx lub +48 (xxx) xxxxxx. Jeżeli wpisany numer będzie rozpoczynał się od “(+”, “00”, “(00”, “(48” modyfikacje jego wartości zostanie ominięta.
Option Explicit Sub CountryPrefix() 'MVP OShon from VBAtools.pl Dim oFolder As MAPIFolder Set oFolder = Application.ActiveExplorer.CurrentFolder If Left(UCase(oFolder.DefaultMessageClass), 11) <> "IPM.CONTACT" Then MsgBox "Przejdź do folder kontaktów.", vbExclamation Exit Sub End If Dim nCounter&, NotCount& nCounter = 0 NotCount = 0 Dim oItem As Object For Each oItem In oFolder.Items Dim oContact As ContactItem Set oContact = oItem If oItem.Class = 40 Then If Not oContact Is Nothing Then With oContact If Len(.AssistantTelephoneNumber) > 0 Then .AssistantTelephoneNumber = Nawiasy(AddPrefix(.AssistantTelephoneNumber)) If Len(.Business2TelephoneNumber) > 0 Then .Business2TelephoneNumber = Nawiasy(AddPrefix(.Business2TelephoneNumber)) If Len(.BusinessFaxNumber) > 0 Then .BusinessFaxNumber = Nawiasy(AddPrefix(.BusinessFaxNumber)) If Len(.BusinessTelephoneNumber) > 0 Then .BusinessTelephoneNumber = Nawiasy(AddPrefix(.BusinessTelephoneNumber)) If Len(.CallbackTelephoneNumber) > 0 Then .CallbackTelephoneNumber = Nawiasy(AddPrefix(.CallbackTelephoneNumber)) If Len(.CarTelephoneNumber) > 0 Then .CarTelephoneNumber = Nawiasy(AddPrefix(.CarTelephoneNumber)) If Len(.CompanyMainTelephoneNumber) > 0 Then .CompanyMainTelephoneNumber = Nawiasy(AddPrefix(.CompanyMainTelephoneNumber)) If Len(.Home2TelephoneNumber) > 0 Then .Home2TelephoneNumber = Nawiasy(AddPrefix(.Home2TelephoneNumber)) If Len(.HomeFaxNumber) > 0 Then .HomeFaxNumber = Nawiasy(AddPrefix(.HomeFaxNumber)) If Len(.HomeTelephoneNumber) > 0 Then .HomeTelephoneNumber = Nawiasy(AddPrefix(.HomeTelephoneNumber)) If Len(.ISDNNumber) > 0 Then .ISDNNumber = Nawiasy(AddPrefix(.ISDNNumber)) If Len(.MobileTelephoneNumber) > 0 Then .MobileTelephoneNumber = NawiasyGSM(AddPrefix(.MobileTelephoneNumber)) If Len(.OtherFaxNumber) > 0 Then .OtherFaxNumber = Nawiasy(AddPrefix(.OtherFaxNumber)) If Len(.OtherTelephoneNumber) > 0 Then .OtherTelephoneNumber = Nawiasy(AddPrefix(.OtherTelephoneNumber)) If Len(.PagerNumber) > 0 Then .PagerNumber = Nawiasy(AddPrefix(.PagerNumber)) If Len(.PrimaryTelephoneNumber) > 0 Then .PrimaryTelephoneNumber = Nawiasy(AddPrefix(.PrimaryTelephoneNumber)) If Len(.RadioTelephoneNumber) > 0 Then .RadioTelephoneNumber = Nawiasy(AddPrefix(.RadioTelephoneNumber)) If Len(.TelexNumber) > 0 Then .TelexNumber = Nawiasy(AddPrefix(.TelexNumber)) If Len(.TTYTDDTelephoneNumber) > 0 Then .TTYTDDTelephoneNumber = Nawiasy(AddPrefix(.TTYTDDTelephoneNumber)) .Save nCounter = nCounter + 1 End With End If Else NotCount = NotCount + 1 End If Next MsgBox "Procedura zmiany formatu numerów telefonów zakończona." & vbCr & vbCr _ & "Folder " & Chr(34) & oFolder.Name & Chr(34) & " zawiera: " _ & oFolder.Items.Count & " kontaktów." & vbCr _ & "-" & nCounter & " kontaktów przetworzonych." & vbCr _ & "-" & NotCount & " opuszczonych obiektów", vbInformation, "VBATools.pl" Set oContact = Nothing Set oFolder = Nothing End Sub Private Function Nawiasy(str) 'MVP OShon from VBATools.pl 'zamienia na "+48(60)1234567" Select Case Len(str) Case 12: str = Left$(str, 3) & "(" & Mid(str, 4, 2) & ")" & Right$(str, 7) Case 11: str = Left$(str, 3) & "(" & Mid(str, 4, 1) & ")" & Right$(str, 7) End Select Nawiasy = str End Function Private Function NawiasyGSM(str) 'MVP OShon from VBATools.pl 'zamienia na "+48(601)234567" Select Case Len(str) Case 12: str = Left$(str, 3) & "(" & Mid(str, 4, 3) & ")" & Right$(str, 6) End Select NawiasyGSM = str End Function Private Function AddPrefix(str) 'zamienia "(12) 345-67-89 " na "+48123456789" 'jeśli nie chcemy kasować pola z tekstem z numerów to odkomentujemy pon liniję linijkę 'str = RemoveNonNumeric(str) If str = "" Then Exit Function If Left(str, 2) = "(+" Then Exit Function If Left(str, 2) = "00" Then Exit Function If Left(str, 3) = "(00" Then Exit Function If Left(str, 3) = "(48" Then Exit Function Dim RegExp As Object Set RegExp = CreateObject("VBScript.RegExp") RegExp.Global = True RegExp.Pattern = "[^d]" str = RegExp.Replace(str, vbNullString) RegExp.Pattern = "^0+" str = RegExp.Replace(str, vbNullString) Select Case Len(str) Case 9: str = "+48" & str Case 10: str = "+" & str Case 11: str = "+" & str Case Else Exit Function End Select AddPrefix = str End Function Private Function RemoveNonNumeric(str) 'usuwa tekst z pola liczbowego Dim I As Long Dim StrLen As Long Dim c As String * 1 StrLen = Len(str) RemoveNonNumeric = "" For I = 1 To StrLen c = Mid(str, I, 1) If c Like "#" Then RemoveNonNumeric = RemoveNonNumeric & c Next I End Function
(c) Shon Oskar – www.VBATools.pl
Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.