[AccessD] OT: Microsoft outlook

Gershon,
The Code below is one function and two subs
The Function FileExist and the Sub SetOutlookReference are used to
determine the version of Outlook being used and if there is a reference
set to Outlook.  It will set the reference if it does not exist.
Both of these are called from within the Sub ChangeOutLook()

The ChangeOutlook Sub will ask you for a number that will be appended to
the beginning of each phone number in your contacts.  It will only
append the number if there is already a number in the field.
You will need to change one line in the ChangeOutlook sub to match the
Personal Folder Name that contains your Contacts.
Hope this helps,
Kevin

'*** Code Start ***
Option Explicit

' Check if file exists
Function FileExist(pstrFileName As String) As Boolean

    Dim intAttr As Integer

    On Error Resume Next
    intAttr = vbDirectory
    intAttr = GetAttr(pstrFileName)
    FileExist = (intAttr And vbDirectory) <> vbDirectory

End Function
Sub SetOutLookReference()

    Dim varmessage As Variant

    On Error GoTo errHandler

    If FileExist(Application.Path & "\MSOUTL8.olb") = True Then
        Application.VBE.ActiveVBProject.References.AddFromFile _
            Application.Path & "\MSOUTL8.olb"
    ElseIf FileExist(Application.Path & "\MSOUTL9.OLB") = True Then
        Application.VBE.ActiveVBProject.References.AddFromFile _
            Application.Path & "\MSOUTL9.olb"
    ElseIf FileExist(Application.Path & "\MSOUTL.OLB") = True Then
        Application.VBE.ActiveVBProject.References.AddFromFile _
            Application.Path & "\MSOUTL.olb"
    End If

    Exit Sub

errHandler:
    Select Case Err.Number
        Case 32813
            'MsgBox "Reference already exists"
            Exit Sub
        Case Else
            varmessage = MsgBox("An error occured while setting up this
file." & Chr(13) & _
            "Please report the error:" & Chr(13) & Err.Number & Chr(13)
& "and error description:" & Chr(13) & _
            Err.Description & Chr(13) & "to the following Mailbox: " &
Chr(13) & _
                        "mailboxemail at yourdomain.com", vbOKOnly,
ThisWorkbook.BuiltinDocumentProperties("title"))
                        '& " Setup Error."))
            Exit Sub
    
End Select
End Sub

Sub ChangeOutLook()

'Determine if there is a reference set to Outlook...If not, add it
Call SetOutLookReference

Dim i
Dim MyNum
Dim ol As New Outlook.Application
Dim olns As Outlook.NameSpace
Dim fldContacts As Outlook.MAPIFolder
Dim itms As Outlook.Items
Dim cf As Object
Dim MyItem As ContactItem
Dim MyOldValue
Set ol = CreateObject("Outlook.Application")
Set olns = ol.GetNamespace("MAPI")

' Which folder is the contacts list in?
'Change this line to match your Contact Folder Name...
Set fldContacts = olns.Folders("Personal Folders").Folders("Contacts")
Set itms = fldContacts.Items

'What number to you want to add to the beginning of your Phone Number?
MyNum = InputBox("Enter the number to add to the beginning of your phone
number", _
"Add digit to your phone number...")

For i = 1 To itms.Count
    Set MyItem = itms(i)
    If Len(MyItem.BusinessTelephoneNumber) <> 0 Then
        MyItem.BusinessTelephoneNumber = MyNum &
MyItem.BusinessTelephoneNumber
    End If
    If Len(MyItem.AssistantTelephoneNumber) <> 0 Then
        MyItem.AssistantTelephoneNumber = MyNum &
MyItem.AssistantTelephoneNumber
    End If
    If Len(MyItem.Business2TelephoneNumber) <> 0 Then
        MyItem.Business2TelephoneNumber = MyNum &
MyItem.Business2TelephoneNumber
    End If
    If Len(MyItem.BusinessFaxNumber) <> 0 Then
        MyItem.BusinessFaxNumber = MyNum & MyItem.BusinessFaxNumber
    End If
    If Len(MyItem.CallbackTelephoneNumber) <> 0 Then
        MyItem.CallbackTelephoneNumber = MyNum &
MyItem.CallbackTelephoneNumber
    End If
    If Len(MyItem.CarTelephoneNumber) <> 0 Then
        MyItem.CarTelephoneNumber = MyNum & MyItem.CarTelephoneNumber
    End If
    If Len(MyItem.CompanyMainTelephoneNumber) <> 0 Then
        MyItem.CompanyMainTelephoneNumber = MyNum &
MyItem.CompanyMainTelephoneNumber
    End If
    If Len(MyItem.Home2TelephoneNumber) <> 0 Then
        MyItem.Home2TelephoneNumber = MyNum &
MyItem.Home2TelephoneNumber
    End If
    If Len(MyItem.HomeFaxNumber) <> 0 Then
        MyItem.HomeFaxNumber = MyNum & MyItem.HomeFaxNumber
    End If
    If Len(MyItem.HomeTelephoneNumber) <> 0 Then
        MyItem.HomeTelephoneNumber = MyNum & MyItem.HomeTelephoneNumber
    End If
    If Len(MyItem.MobileTelephoneNumber) <> 0 Then
        MyItem.MobileTelephoneNumber = MyNum &
MyItem.MobileTelephoneNumber
    End If
    If Len(MyItem.OtherFaxNumber) <> 0 Then
        MyItem.OtherFaxNumber = MyNum & MyItem.OtherFaxNumber
    End If
    If Len(MyItem.OtherTelephoneNumber) <> 0 Then
        MyItem.OtherTelephoneNumber = MyNum &
MyItem.OtherTelephoneNumber
    End If
    If Len(MyItem.PagerNumber) <> 0 Then
        MyItem.PagerNumber = MyNum & MyItem.PagerNumber
    End If
    If Len(MyItem.PrimaryTelephoneNumber) <> 0 Then
        MyItem.PrimaryTelephoneNumber = MyNum &
MyItem.PrimaryTelephoneNumber
    End If
    If Len(MyItem.RadioTelephoneNumber) <> 0 Then
        MyItem.RadioTelephoneNumber = MyNum &
MyItem.RadioTelephoneNumber
    End If
    If Len(MyItem.TelexNumber) <> 0 Then
        MyItem.TelexNumber = MyNum & MyItem.TelexNumber
    End If
    If Len(MyItem.TTYTDDTelephoneNumber) <> 0 Then
        MyItem.TTYTDDTelephoneNumber = MyNum &
MyItem.TTYTDDTelephoneNumber
    End If
        itms(i).Save
        
Next i

End Sub
'*** Code End ***

-----Original Message-----
From: accessd-bounces at databaseadvisors.com
[mailto:accessd-bounces at databaseadvisors.com] On Behalf Of
handyman at actcom.co.il
Sent: Saturday, August 30, 2003 10:24 PM
To: accessd at databaseadvisors.com
Subject: [AccessD] OT: Microsoft outlook


Sorry for the OT.  I need to make a global change to all phone numbers
in 
the Microsoft Outlook contacts, as new digit is being added to the phone

numbers.  Does anyone know how I can do this?  There are thousands of 
entries, and the thought of doing it by hand is nerve-racking.  I guess 
after this I'll have to worry about the information on a Palm....

Thanks

Gershon Markowitz
mailto:Handyman at actcom.co.il

_______________________________________________
AccessD mailing list
AccessD at databaseadvisors.com
http://databaseadvisors.com/mailman/listinfo/accessd
Website: http://www.databaseadvisors.com