Rechercher un contact et l'exporter (.msg) [Résolu]

[NooD]

Bonjour à tous,

Y aurait-il un quelconque moyen pour injecter des fichiers .msg dans un fichier .pst ?
Voir plus bas...

Merci d'avance.

Bonne journée.

[NooD]

A defaut de pouvoir faire une injection, j'exporte le .msg d'un contact (après recherche de ce dernier). La recherche s'effectue à partir de son email :

Code :

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
  Dim objApp As Application
  Dim objNS As NameSpace
  Dim objContacts As MAPIFolder
  Dim colItems As Items
  Dim objItem As Object
  Dim strAddress As String
  Dim strWhere As String
  Dim blnFound As Boolean
 
  ' get folder to search
  Set objApp = CreateObject("Outlook.Application")
  Set objNS = objApp.GetNamespace("MAPI")
  Set objContacts = objNS.GetDefaultFolder(olFolderContacts)
  strWhere = "[Email1Address] <> vbNullString " & _
             "Or [Email2Address] <> vbNullString " & _
             "Or [Email3Address] <> vbNullString "
  Set colItems = objContacts.Items.Restrict(strWhere)
 
  ' get address to search for
  strAddress = InputBox("Find an Address in Contacts")
  If strAddress <> "" Then
    colItems.SetColumns ("Email1Address")
    For Each objItem In colItems
      ' must test for item type to avoid distribution lists
      If TypeName(objItem) = "ContactItem" Then
        If InStr(objItem.Email1Address, strAddress) > 0 Then
          objItem.Display
          blnFound = True
          Exit For
        ElseIf InStr(objItem.Email2Address, strAddress) > 0 Then
          objItem.Display
          blnFound = True
          Exit For
        ElseIf InStr(objItem.Email3Address, strAddress) > 0 Then
          objItem.Display
          blnFound = True
          Exit For
        End If
      End If
    Next
  End If
 
  If Not blnFound Then
    MsgBox "Not Found"
  End If
 
 objItem.SaveAs ("PATH")
 
  Set objItem = Nothing
  Set colItems = Nothing
  Set objContacts = Nothing
  Set objNS = Nothing
  Set objApp = Nothing

Problème, la recherche ne s'effectue pas dans le bon PST. Elle se fait dans le dossier principal. Comment lui indiquer le nom du bon PST ?

[NooD]

Bonjour,

Pour choisir le fichier PST il faut remplacer le code :

Code :

1
2
Set objNS = objApp.GetNamespace("MAPI")
Set objContacts = objNS.GetDefaultFolder(olFolderContacts)

Par :

Code :

1
2
Set objContacts = objApp.GetNamespace("MAPI").Folders("NOM DU DOSSIER PRINCIPAL DE VOTRE PST")
Set objContacts = objContacts.Folders("NOM DU SOUS DOSSIER (EXEMPLE NOM DU CARNET D'ADRESSE")

Reste plus qu'à exporter le résultat

[NooD]

J'arrive à effectuer une recherche mais impossible d'exporter le contact, pourtant la syntaxe semble correcte.

Code :

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
Sub FindEmailAddressInContacts()
  Dim objApp As Application
  Dim objNS As NameSpace
  Dim objContacts As MAPIFolder
  Dim colItems As Items
  Dim objItem As Object
  Dim strAddress As String
  Dim strWhere As String
  Dim blnFound As Boolean
 
  ' get folder to search
  Set objApp = CreateObject("Outlook.Application")
  'Set objNS = objApp.GetNamespace("MAPI")
  Set objContacts = objApp.GetNamespace("MAPI").Folders("Contacts G")
  Set objContacts = objContacts.Folders("Contacts")
  'Set objContacts = objNS.GetDefaultFolder(olFolderContacts)
  strWhere = "[Email1Address] <> vbNullString "
  Set colItems = objContacts.Items.Restrict(strWhere)
 
  ' get address to search for
  strAddress = InputBox("Find an Address in Contacts")
  If strAddress <> "" Then
    colItems.SetColumns ("Email1Address")
    For Each objItem In colItems
      ' must test for item type to avoid distribution lists
      If TypeName(objItem) = "ContactItem" Then
        If InStr(objItem.Email1Address, strAddress) > 0 Then
          'objItem.Display
          blnFound = True
          objItem.SaveAs "C:\file.msg"
          Exit For
        End If
      End If
    Next
  End If
 
  If Not blnFound Then
    MsgBox "Not Found"
  End If
 
  Set objItem = Nothing
  Set colItems = Nothing
  Set objContacts = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Sub

Il s'agit de la ligne : objItem.SaveAs "C:\file.msg" qui passe mais apparement ne fait rien.
Une idée ?

[NooD]

L'exportation est réussie.
En fait il faut utiliser une variable de type ContactItem plutôt que Item pour que le SaveAs fonctionne bien.

Voici le code :

Code :

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
Sub FindEmailAddressInContacts()
  Dim objApp As Application
  Dim objNS As NameSpace
  Dim objFolders As MAPIFolder
  Dim colItems As Items
  Dim strAddress As String
  Dim strWhere As String
  Dim blnFound As Boolean
  Dim objContact As ContactItem
 
  ' get folder to search
  Set objApp = CreateObject("Outlook.Application")
 
  'Set objNS = objApp.GetNamespace("MAPI")
  Set objFolders = objApp.GetNamespace("MAPI").Folders("Contacts G")
  Set objFolders = objFolders.Folders("Contacts")
 
  'Set objContacts = objNS.GetDefaultFolder(olFolderContacts)
  strWhere = "[Email1Address] <> vbNullString "
  Set colItems = objFolders.Items.Restrict(strWhere)
 
  ' get address to search for
  strAddress = InputBox("Find an Address in Contacts")
 
  If strAddress <> "" Then
 
    For Each objContact In colItems
 
      ' must test for item type to avoid distribution lists
      If TypeName(objContact) = "ContactItem" Then
 
        If InStr(objContact.Email1Address, strAddress) > 0 Then
          blnFound = True
          objContact.SaveAs "C:\file.msg"
          Exit For
        End If
 
      End If
    Next
  End If
 
  If Not blnFound Then
    MsgBox "Not Found"
  End If
 
  Set objContact = Nothing
  Set colItems = Nothing
  Set objFolders = Nothing
  Set objNS = Nothing
  Set objApp = Nothing
End Sub

Manque plus que l'importation...

[NooD]

L'importation continue dans un nouveau sujet...