VBATools

Dodanie +48 i zmiana formatu telefonów w książce adresowej

by 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.
:, , , , , , , ,

Leave a Reply