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 105 106 107 108 109 110 111 112 113 114 115 116 117
|
Sub Transfert()
Dim db As DAO.Database, rst As DAO.Recordset, fld As DAO.Field
Dim rst2 As DAO.Recordset
Dim sSQL As String
Dim olApp As Object
Dim olNs As Object
Set olApp = CreateObject("Outlook.Application")
Set olNs = olApp.GetNamespace("MAPI")
olNs.Logon
Dim newContact As Object
Dim prenom As String
Dim nom As String
Dim mail As String
Dim num As Integer
Dim adresse1, adresse2, adresse3 As String
Dim ville As String
Dim postal As String
Dim pays As String
Dim i As Integer
Dim test As String
num = 0
' Ouverture de la base de données
Set db = DBEngine.OpenDatabase("D:\BDL\BDL_PRG\Test.mdb")
sSQL = "SELECT * FROM Contacts"
' Ouverture du recordset
Set rst = db.OpenRecordset(sSQL, dbOpenForwardOnly, dbReadOnly)
''''''''''''''''''''''''''''''''''''''''''''''''''
Dim olContact As Outlook.ContactItem ' Contact Outlook
Dim olSearch As Outlook.Search ' Recherche Contact précédent
Dim olResult As Outlook.Results ' Resultat de la recherche
Dim j As Integer ' Compteur
Dim cle As String
Dim bool As Boolean
''''''''''''''''''''''''''''''''''''''''''''''''''
test = False
Do While Not rst.EOF
' Initialisation des variables
prenom = ""
num = num + 1
nom = ""
mail = ""
adresse = ""
ville = ""
postal = ""
pays = ""
' Recherche le contact ayant la meme clé primaire (placé dans le telephonne personel)
Set olSearch = olApp.AdvancedSearch("'Contacts'", "urn:schemas:contacts:homePhone = '" & rst![Code] & "|" & rst![fonction] & "|" & rst![tel] & "|" & rst![origine] & "|" & rst![CODE_SOCIETE] & "'")
' Place le résultat dans olResult
Set olResult = olSearch.Results
If Not (olResult.Count = 0) Then
olResult.Item(olResult.Count).Delete
bool = True
End If
' Destruction des objets qui ne seront plus utilisés
Set olResult = Nothing
Set olSearch = Nothing
Set newContact = olApp.CreateItem(olContactItem)
' Mise en place de la clé primaire dans le champs du telephone personnel
newContact.HomeTelephoneNumber = rst![Code] & "|" & rst![fonction] & "|" & rst![tel] & "|" & rst![origine] & "|" & rst![CODE_SOCIETE]
' Test toutes les chaines pour savoir si elles sont renseignées ou non
If Nz(rst![nom], "") <> "" Then
newContact.FullName = rst![nom]
End If
If Not IsNull(rst![E_mail]) Then
newContact.Email1Address = rst![E_mail]
Else
newContact.Email1Address = ""
End If
newContact.CustomerID = num
If Nz(rst![tel], "") <> "" Then
newContact.PrimaryTelephoneNumber = rst![tel]
End If
If Nz(rst![adresse1], "") <> "" Then
adresse1 = rst![adresse1]
Else
adresse1 = ""
End If
If Nz(rst![adresse2], "") <> "" Then
adresse2 = rst![adresse2]
Else
adresse2 = ""
End If
If Nz(rst![adresse3], "") <> "" Then
adresse3 = rst![adresse3]
Else
adresse3 = ""
End If
newContact.MailingAddressStreet = adresse1 & adresse2 & adresse3
If Nz(rst![ville], "") <> "" Then
newContact.MailingAddressCity = rst![ville]
End If
If Nz(rst![Code_Postal], "") <> "" Then
newContact.MailingAddressPostalCode = rst![Code_Postal]
End If
If Nz(rst![pays], "") <> "" Then
newContact.MailingAddressState = rst![pays]
End If
If Nz(rst![fonction], "") <> "" Then
newContact.JobTitle = rst![fonction]
End If
If Not Nz(rst![tel], "") <> "" Then
newContact.PrimaryTelephoneNumber = rst![tel]
End If
newContact.Save
rst.MoveNext
Loop
If (bool) Then
MsgBox ("Les contacts ont étés insérés, mais il y a eu des doublons")
Else
MsgBox ("Les contacts ont étés insérés sans aucun problème")
End If
' Fermeture du Recordset
rst.Close
End Sub |
Partager