|
begin process at 2008 07 04 08:50:47
Derniers logiciels
|
Trouver une ressource (Nouvelle version du moteur, plus rapide & pertinent, essayez le !)
Vous ne trouvez pas de réponse à votre problème ? Alors posez la question dans le forum.
Souvenez-vous qu'il n'y a jamais de question bête, mais rester dans l'ignorance parce que l'on n'ose pas poser une question, ça c'est une erreur !
CRÉER DES CONTACTS AVEC LES MESSAGES DE OUTLOOK
Description
La base de donnée est la pour qu'il n'y ait pas de doublons parce que les méthode GetNext du folder de contact n'ont pas l'air de fonctionner vraiment bien. Si quelqu'un sait comment ca marche je suis ouvert aux suggestions.
Source
- Option Explicit
- Dim objApp As Outlook.Application
- Dim Contact As ContactItem
- Dim rsTmp As Recordset
-
- Private Sub AjoutContact(Sender As String, Adresse As String)
-
- 'Créer une instance de Outlook
- Set objApp = CreateObject("Outlook.Application")
-
- Dim ContactItem As Outlook.ContactItem
- 'Crée une nouvelle instance de contact
- Set Contact = objApp.CreateItem(olContactItem)
- 'Copie le nom de la personne qui à envoyer le email dans le contact
- Contact.FullName = Sender
- Contact.Email1Address = Adresse
- 'Sauvegarde le contact
- Contact.Save
-
- 'Ajoute le contact dans la base de données
- rsTmp.AddNew
- rsTmp!Nom = Sender
- rsTmp!email = Adresse
- rsTmp.Update
- rsTmp.Requery
- Set Contact = Nothing
-
- End Sub
-
- Private Sub Command1_Click()
- Dim objApp As Outlook.Application
- Dim objConn As Connection
- 'Dim objNS As NameSpace
- Dim Contact As ContactItem
- Dim ContactFolder As MAPIFolder
- Dim Boite As MAPIFolder
- Dim Sent As MAPIFolder
- Dim Item As Outlook.MailItem
- Dim Msg As Outlook.MailItem
- Dim Recipent As Outlook.Recipient
- Dim ctr As Single
- Dim str As String
-
- 'Ouverture d'un recordset pour qu'il n'y ait pas de doublons
- Set objConn = New Connection
- objConn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\tmp.mdb;Persist Security Info=False")
- Set rsTmp = New ADODB.Recordset
- rsTmp.Open "Select * from table1", objConn.ConnectionString, adOpenKeyset, adLockOptimistic
-
- 'Supprime ce qu'il y a dans la table
- If rsTmp.RecordCount > 0 Then
- rsTmp.MoveFirst
- While rsTmp.RecordCount > 0
- rsTmp.Delete adAffectCurrent
- rsTmp.Requery
- Wend
- End If
-
- 'Label pour me dire quand l'opération est terminée
- Label1.Visible = False
-
- 'Créer une instance de Outlook
- Set objApp = CreateObject("Outlook.Application")
-
- 'Crée un NameSpace (je sais pas à quoi ça sert, donc je l'ai remplacé!)
- 'Set objNS = objApp.GetNamespace("MAPI")
-
- 'Associe la boîte de réception avec la variable boite
- Set Boite = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
-
-
- 'Associe le dossier "Éléments envoyés" avec la variable Sent
- Set Sent = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
-
- 'Associe le dossier de contact avec la varible ContactFolder
- Set ContactFolder = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
-
- 'Calcul le nombre d'item dans la boîte de réception et éléments envoyés
- ctr = Boite.Items.Count + Sent.Items.Count
-
- 'Calcul de combien doit avancer la progress bar chaque fois qu'elle a terminé avec un enregistrement
- ctr = Round(100 / ctr, 1)
- Progress.Value = 0
-
-
- 'PROCÉDURE POUR LA BOÎTE DE RÉCEPTION
-
- For Each Item In Boite.Items
- Progress.Value = Progress.Value + ctr
-
- 'Crée une réponse au message dans la boîte de réception pour avoir l'adresse de la personne
- Set Msg = Item.Reply
-
- For Each Recipent In Msg.Recipients
- If rsTmp.RecordCount > 0 Then
- rsTmp.MoveFirst
- 'Vérifie si ce contact à déjà été ajouté existe déjà
- rsTmp.Find ("Nom = '" & Item.SenderName & "'")
- If rsTmp.EOF Then
-
- Call AjoutContact(Item.SenderName, Recipent.Address)
-
- End If
- Else
-
- Call AjoutContact(Item.SenderName, Recipent.Address)
-
- End If
- Next Recipent
- Next Item
-
-
- 'PROCÉDURE POUR LES "ÉLÉMENTS ENVOYÉS
-
- For Each Item In Sent.Items
- If Progress.Value + ctr > 100 Then
- Progress.Value = 100
- Else
- Progress.Value = Progress.Value + ctr
- End If
-
-
- ' For Each Recipent In msg.Recipients
- If rsTmp.RecordCount > 0 Then
-
- rsTmp.MoveFirst
-
- 'Traitement sur l'addresse de la personne parce que quelle que fois, elle vient avec de "
- 'au bout et d'autre fois elle vien sous la forme de 'Nom (email)'
- If InStr(1, Item.To, "(") Then
- str = Mid(Trim(Item.To), InStr(1, Item.To, "(") + 1, Len(Item.To))
- str = Left(str, Len(str) - 1)
- Else
- str = Left(Item.To, Len(Item.To) - 1)
- str = Mid(str, 2, Len(str))
- End If
-
- 'Recherche cette adresse dans la base de données
- rsTmp.Find ("email = '" & str & "'")
- If rsTmp.EOF Then
-
- Call AjoutContact(Item.SenderName, str)
-
- End If
- Else
- Call AjoutContact(Item.SenderName, str)
-
- End If
- Next Item
-
- Label1.Visible = True
- Progress.Value = 0
-
- rsTmp.Close
-
- Set rsTmp = Nothing
- Set Boite = Nothing
- Set Sent = Nothing
- Set ContactFolder = Nothing
- Set Item = Nothing
- Set Recipent = Nothing
-
- End Sub
-
Option Explicit
Dim objApp As Outlook.Application
Dim Contact As ContactItem
Dim rsTmp As Recordset
Private Sub AjoutContact(Sender As String, Adresse As String)
'Créer une instance de Outlook
Set objApp = CreateObject("Outlook.Application")
Dim ContactItem As Outlook.ContactItem
'Crée une nouvelle instance de contact
Set Contact = objApp.CreateItem(olContactItem)
'Copie le nom de la personne qui à envoyer le email dans le contact
Contact.FullName = Sender
Contact.Email1Address = Adresse
'Sauvegarde le contact
Contact.Save
'Ajoute le contact dans la base de données
rsTmp.AddNew
rsTmp!Nom = Sender
rsTmp!email = Adresse
rsTmp.Update
rsTmp.Requery
Set Contact = Nothing
End Sub
Private Sub Command1_Click()
Dim objApp As Outlook.Application
Dim objConn As Connection
'Dim objNS As NameSpace
Dim Contact As ContactItem
Dim ContactFolder As MAPIFolder
Dim Boite As MAPIFolder
Dim Sent As MAPIFolder
Dim Item As Outlook.MailItem
Dim Msg As Outlook.MailItem
Dim Recipent As Outlook.Recipient
Dim ctr As Single
Dim str As String
'Ouverture d'un recordset pour qu'il n'y ait pas de doublons
Set objConn = New Connection
objConn.Open ("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\tmp.mdb;Persist Security Info=False")
Set rsTmp = New ADODB.Recordset
rsTmp.Open "Select * from table1", objConn.ConnectionString, adOpenKeyset, adLockOptimistic
'Supprime ce qu'il y a dans la table
If rsTmp.RecordCount > 0 Then
rsTmp.MoveFirst
While rsTmp.RecordCount > 0
rsTmp.Delete adAffectCurrent
rsTmp.Requery
Wend
End If
'Label pour me dire quand l'opération est terminée
Label1.Visible = False
'Créer une instance de Outlook
Set objApp = CreateObject("Outlook.Application")
'Crée un NameSpace (je sais pas à quoi ça sert, donc je l'ai remplacé!)
'Set objNS = objApp.GetNamespace("MAPI")
'Associe la boîte de réception avec la variable boite
Set Boite = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
'Associe le dossier "Éléments envoyés" avec la variable Sent
Set Sent = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderSentMail)
'Associe le dossier de contact avec la varible ContactFolder
Set ContactFolder = objApp.GetNamespace("MAPI").GetDefaultFolder(olFolderContacts)
'Calcul le nombre d'item dans la boîte de réception et éléments envoyés
ctr = Boite.Items.Count + Sent.Items.Count
'Calcul de combien doit avancer la progress bar chaque fois qu'elle a terminé avec un enregistrement
ctr = Round(100 / ctr, 1)
Progress.Value = 0
'PROCÉDURE POUR LA BOÎTE DE RÉCEPTION
For Each Item In Boite.Items
Progress.Value = Progress.Value + ctr
'Crée une réponse au message dans la boîte de réception pour avoir l'adresse de la personne
Set Msg = Item.Reply
For Each Recipent In Msg.Recipients
If rsTmp.RecordCount > 0 Then
rsTmp.MoveFirst
'Vérifie si ce contact à déjà été ajouté existe déjà
rsTmp.Find ("Nom = '" & Item.SenderName & "'")
If rsTmp.EOF Then
Call AjoutContact(Item.SenderName, Recipent.Address)
End If
Else
Call AjoutContact(Item.SenderName, Recipent.Address)
End If
Next Recipent
Next Item
'PROCÉDURE POUR LES "ÉLÉMENTS ENVOYÉS
For Each Item In Sent.Items
If Progress.Value + ctr > 100 Then
Progress.Value = 100
Else
Progress.Value = Progress.Value + ctr
End If
' For Each Recipent In msg.Recipients
If rsTmp.RecordCount > 0 Then
rsTmp.MoveFirst
'Traitement sur l'addresse de la personne parce que quelle que fois, elle vient avec de "
'au bout et d'autre fois elle vien sous la forme de 'Nom (email)'
If InStr(1, Item.To, "(") Then
str = Mid(Trim(Item.To), InStr(1, Item.To, "(") + 1, Len(Item.To))
str = Left(str, Len(str) - 1)
Else
str = Left(Item.To, Len(Item.To) - 1)
str = Mid(str, 2, Len(str))
End If
'Recherche cette adresse dans la base de données
rsTmp.Find ("email = '" & str & "'")
If rsTmp.EOF Then
Call AjoutContact(Item.SenderName, str)
End If
Else
Call AjoutContact(Item.SenderName, str)
End If
Next Item
Label1.Visible = True
Progress.Value = 0
rsTmp.Close
Set rsTmp = Nothing
Set Boite = Nothing
Set Sent = Nothing
Set ContactFolder = Nothing
Set Item = Nothing
Set Recipent = Nothing
End Sub
Conclusion
Petite appli plutot inutile.
J'avais perdu mes contact dans Outlook et je n'avais pas vraiment le gout de les retapper. Donc, cette appli crée un contact avec l'adresse de chaque message de la boite de réception et dans les éléments envoyé.
J'ai cru que ca pouvais p-e aidé qqun qui a besoin de se promener un peu dans Outlook.
Seul problème: Avec Office Xp il faut autorisé l'accès à Outlook avant que le prog puisse s'exécuter
Soyez indulgent, c'est ma première source que je poste
Fichier Zip
Pour les "Membres Club", vous pouvez télécharger directement un fichier contenu dans le zip sans télécharger le zip en entier !
Télécharger le zip
Sources de la même categorie
Commentaires
|
CalendriCode
| | | L | M | M | J | V | S | D |
| | 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 | | | |
|
|
|