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

Recently Active Members

Profile picture of vbatools
Profile picture of Karol Stilger
Profile picture of marcinmachalowski
Profile picture of Joanna Subik
Profile picture of Anorak
Profile picture of programistaaccess
Profile picture of piotrpawlik
Profile picture of Emil Wasilewski
Profile picture of kicekpicek
Profile picture of coldfusion
Profile picture of Gosia Borzęcka
Profile picture of lukaszch
Profile picture of itadministracja
Profile picture of farbenia
Profile picture of Łukasz Kałużny
Profile picture of kabzinski
Profile picture of rtynski
Profile picture of leszekbetlinski
Profile picture of Iv
Profile picture of Justyna Spychała