Reporter | |
VBOffice Reporter is an easy to use tool for data analysis and reporting in Outlook. A single click, for instance, allows you to see the number of hours planned for meetings the next month. |
This example converts certain telephone and fax numbers to a unique format: '+Country Code (Area Code) Number'. See the FormatPhonenumbers_Ex function for which numbers are covered (BusinessTelephoneNumber, BusinessFaxNumber etc.).
At the top see the FormatPhonenumbers function, there the line m_DebugMode = True. This setting means the original number and the result of the conversion will be printed only to the debug window (ctrl+g). This way you can test whether or not the result would be correct. If you change that line to m_DebugMode = False and run the procedure again, the changes will be saved to the contacts.
In the procedure ParseNumber there is the constant Def_CountryCode, which holds the German country code by default. If the country code is missing for a number, this default code will be inserted. Change the value to your own country code if necessary.
Add a new module to the Outlook VBA project, and paste all the code. You can call it by pressing ALT+F8.
Private m_DebugMode As Boolean Public Sub FormatPhonenumbers() Dim coll As VBA.Collection Dim obj As Object Dim Contact As Outlook.ContactItem Dim IsInspector As Boolean 'If True, results will only be printed to the debug window (ctrl+g) 'If False, changes will be made to the contacts and saved. m_DebugMode = True Set coll = GetCurrentItems(IsInspector) If coll.Count = 0 Then Exit Sub For Each obj In coll If TypeOf obj Is Outlook.ContactItem Then Set Contact = obj If m_DebugMode Then Debug.Print "--" & vbCrLf & Contact.FileAs End If FormatPhonenumbers_Ex Contact If m_DebugMode = False And IsInspector = False Then If Contact.Saved = False Then Contact.Save End If End If Next End Sub Private Sub FormatPhonenumbers_Ex(Contact As Outlook.ContactItem) Dim cc$, vw$, no$, OldNo$, NewNo$ Dim IsFax As Boolean OldNo = Contact.BusinessTelephoneNumber If Len(OldNo) Then ParseNumber OldNo, cc, vw, no, IsFax NewNo = JoinNumber(cc, vw, no, IsFax) If m_DebugMode Then Debug.Print OldNo: Debug.Print NewNo & vbCrLf ElseIf OldNo <> NewNo Then Contact.BusinessTelephoneNumber = NewNo End If End If OldNo = Contact.BusinessFaxNumber If Len(OldNo) Then ParseNumber OldNo, cc, vw, no, IsFax NewNo = JoinNumber(cc, vw, no, IsFax) If m_DebugMode Then Debug.Print OldNo: Debug.Print NewNo & vbCrLf ElseIf OldNo <> NewNo Then Contact.BusinessFaxNumber = NewNo End If End If OldNo = Contact.CompanyMainTelephoneNumber If Len(OldNo) Then ParseNumber OldNo, cc, vw, no, IsFax NewNo = JoinNumber(cc, vw, no, IsFax) If m_DebugMode Then Debug.Print OldNo: Debug.Print NewNo & vbCrLf ElseIf OldNo <> NewNo Then Contact.CompanyMainTelephoneNumber = NewNo End If End If OldNo = Contact.HomeTelephoneNumber If Len(OldNo) Then ParseNumber OldNo, cc, vw, no, IsFax NewNo = JoinNumber(cc, vw, no, IsFax) If m_DebugMode Then Debug.Print OldNo: Debug.Print NewNo & vbCrLf ElseIf OldNo <> NewNo Then Contact.HomeTelephoneNumber = NewNo End If End If OldNo = Contact.MobileTelephoneNumber If Len(OldNo) Then ParseNumber OldNo, cc, vw, no, IsFax NewNo = JoinNumber(cc, vw, no, IsFax) If m_DebugMode Then Debug.Print OldNo: Debug.Print NewNo & vbCrLf ElseIf OldNo <> NewNo Then Contact.MobileTelephoneNumber = NewNo End If End If End Sub Private Function JoinNumber(cc$, vw$, no$, IsFax As Boolean) As String Dim n$ If IsFax Then n = "Fax: " If Len(cc) Then n = n & cc If Len(vw) Then vw = " (" & vw & ") " n = n & vw n = n & no JoinNumber = n End Function Private Sub ParseNumber(ByVal Number$, cc$, vw$, no$, IsFax As Boolean) Dim p1&, p2& Dim i& Const Def_CountryCode As String = "+49" cc = "": vw = "": no = "" Number = Trim$(Number) If LCase$(Left$(Number, 4)) = "fax:" Then IsFax = True Number = Trim$(Mid$(Number, 5)) Else IsFax = False End If If Left$(Number, 2) = "00" Then Number = "+" & Mid$(Number, 3) If Left$(Number, 1) = "0" Then Number = Mid$(Number, 2) If Left$(Number, 1) <> "+" Then 'Assuming the country code is missing, insert the own country code. Number = Def_CountryCode & " " & Number End If Number = Replace(Number, "/", " ") Number = Replace(Number, "-", " ") Number = Replace(Number, "(0", "(") Number = Replace(Number, "(", " ") Number = Replace(Number, ")", " ") While InStr(Number, " ") > 0 Number = Replace(Number, " ", " ") Wend If Left$(Number, 1) = "+" Then For i = 2 To Len(Number) If IsNumeric(Mid$(Number, i, 1)) = False Then If p1 = 0 Then p1 = i ElseIf p2 = 0 Then p2 = i Else Exit For End If End If Next If p1 = 0 Then no = Number Else cc = Mid$(Number, 1, p1 - 1) If p2 Then vw = Mid$(Number, p1 + 1, p2 - p1 - 1) no = Mid$(Number, p2 + 1) Else no = Mid$(Number, p1) End If End If End If End Sub Private Function GetCurrentItems(Optional IsInspector As Boolean) As VBA.Collection Dim coll As VBA.Collection Dim Win As Object Dim Sel As Outlook.Selection Dim obj As Object Dim i& Set coll = New VBA.Collection Set Win = Application.ActiveWindow If TypeOf Win Is Outlook.Inspector Then IsInspector = True coll.add Win.CurrentItem Else IsInspector = False Set Sel = Win.Selection If Not Sel Is Nothing Then For i = 1 To Sel.Count coll.add Sel(i) Next End If End If Set GetCurrentItems = coll End Function
OLKeeper | |
OLKeeper reliably prevents users from closing their Outlook window and thus possibly missing reminders or e-mails. |