1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104
|
Sub Create_Contacts()
Dim myOlApp As New Outlook.Application ' variable application outlook
Dim myOlNameSpace As Namespace
Dim myWorkFolder As Variant '???Folders
Dim myNewContact As ContactItem
Dim tabMyWorkFolder(1) As String '2 répertoires disponible
Dim intIndexMaxTabFolder As Integer
Dim intIndexTabFolder As Integer
Dim strTestChamps As String
Dim intTestPhone As Integer
'Initialisation des noms de folders disponibles
tabMyWorkFolder(0) = "Clients"
tabMyWorkFolder(1) = "Fourniss & Contacts Pro's"
intIndexMaxTabFolder = 1
'initialisation de l'object outlook
Set myOlApp = CreateObject("Outlook.Application")
Set myOlNameSpace = myOlApp.GetNamespace("MAPI")
Set myNewContact = myOlApp.CreateItem(olContactItem)
' choix du répertoire d'enregistrement du contact
'Boucle jusqu'à ce que le bon répertoire soit selectionné
Do
Set myWorkFolder = myOlNameSpace.PickFolder
' si myWorkFolder = cancel
If myWorkFolder Is Nothing Then
Exit Sub
Else
For intIndexTabFolder = 0 To intIndexMaxTabFolder
If myWorkFolder = tabMyWorkFolder(intIndexTabFolder) Then
Exit Do
End If
Next intIndexTabFolder
End If
Loop
' enregistrement du contact
' encodage des champs automatiques
With myNewContact
Select Case myWorkFolder
Case tabMyWorkFolder(0) 'clients
.HomeAddressCountry = "Belgium"
.SelectedMailingAddress = olHome
.Categories = "Clients"
Case tabMyWorkFolder(1) 'fournisseur
.BusinessAddressCountry = "Belgium"
.SelectedMailingAddress = olBusiness
End Select
Do 'test les numéros de tél et mail si nécessaire
Do 'test des champs obligatoires pour les adresses
.Display (vbModal)
strTestChamps = ""
Select Case myWorkFolder
Case tabMyWorkFolder(0) 'clients
If .Title = "" Then
strTestChamps = strTestChamps & "Le titre, "
End If
'if ...
'end if
Case tabMyWorkFolder(1) 'fournisseur
.FileAs = .CompanyAndFullName
If .CompanyName = "" Then
strTestChamps = strTestChamps & "Société?, "
End If
'if ...
'end if
End Select
' test si un champs est manquant pour affichage du message
If strTestChamps <> "" Then
strTestChamps = Left(strTestChamps, Len(strTestChamps) - 2) & " sont à compléter"
MsgBox strTestChamps
End If
Loop Until strTestChamps = ""
intTestPhone = 6
If .Business2TelephoneNumber = "" And .BusinessTelephoneNumber = "" And .BusinessFaxNumber = "" _
And .Home2TelephoneNumber = "" And .HomeTelephoneNumber = "" And .HomeFaxNumber = "" _
And .Email1Address = "" And .Email2Address = "" And .Email3Address = "" Then
intTestPhone = MsgBox("Voulez-vous continuer sans introduire de tél. ou de mail?", vbYesNo, "Communication")
End If
Loop Until intTestPhone = 6 '6 = yes // 7 = No
End With
'l'enregistrement du contact se fait automatiquement dans le répertoire par défaut d'outlook
' ==> il faut le déplacer dans le répertoire voulu
myNewContact.Move myWorkFolder
End Sub |
Partager