Bonsoir
J'ai réalisé une macro excel qui me permet de gérer les courriers (postaux)
Saisie:
Nom du destinataire
De l'expéditeur
De l'objet
Génération:
D'un N° de Chrono indexé
Ouverture d'un doc Word
Insertion des données saisie plus haut etc......
Pas de Problèmes
Par contre j'aurai souhté pouvoir récuprer:
les adresses dans OutLook
sélectionner adresse privée ou bureau
mes contacts dans outLook étant organisés
en Dosssiers et sous dossiers en cascades
J'ai écrit une macro qui me permet de les lister.
Par contre je ne reconstitue pas l'arborescence
La recherche se faisant à partir du nom de famille
celà implique une exploration complète de tous les items et de sélectionner les éventuels
doublons.
Je suis preneur de toutes les solutions qui simplifieraient la requête.
Par contre ce qui me semblerait plus simple si c'est possible
A partir d'outlook ouvert
par sélection du contact Click
de "récupérer sa position" dans une variable....!!!!
Ci dessous mon code
Ouvert à "toutes les critique" et surtout à toutes les améliorations.
merci par avance
'*********************************
Option Explicit
Sub Imports_contact()
Dim olApp As New Outlook.Application
Dim nmsName As Namespace
Dim fldFolder As Object, Tab_Fld() As Object, tab_Temp() As Object
Dim Folders As Object
Dim Tab_Sortie() As String
Dim i As Integer, Inds As Integer
Dim K As Long, Ind As Long, Indt As Long, IndFld As Long
'===========
Set olApp = Outlook.Application
Set nmsName = olApp.GetNamespace("MAPI")
Set fldFolder = nmsName.GetDefaultFolder(olFolderContacts)
'====================================
ReDim Preserve Tab_Sortie(0)
ReDim Tab_Fld(0)
ReDim tab_Temp(0)
'====================================
Set Tab_Fld(0) = fldFolder
'====================================
Do
i = 0
'====================================
Tab_Sortie(Inds) = Tab_Fld(i).Name
For Each Folders In Tab_Fld(0).Folders
Set tab_Temp(i) = Tab_Fld(0).Folders(i + 1)
i = i + 1
ReDim Preserve tab_Temp(i)
Next
If tab_Temp(0) Is Nothing Then
Else
ReDim Preserve tab_Temp(UBound(tab_Temp) - 1)
End If
IndFld = UBound(tab_Temp)
'====================================
Select Case i
Case 0
For K = 1 To UBound(Tab_Fld)
Set Tab_Fld(K - 1) = Tab_Fld(K)
Next K
If UBound(Tab_Fld) = 0 Then
ReDim Tab_Fld(0)
Exit Do
Else
ReDim Preserve Tab_Fld(UBound(Tab_Fld) - 1)
End If
'====================================
Case Else
' Remplacer tab_Fld par tab temp
IndFld = UBound(Tab_Fld)
If UBound(Tab_Fld) = 0 Then
ReDim Preserve Tab_Fld(UBound(tab_Temp))
For i = 0 To UBound(Tab_Fld)
Set Tab_Fld(i) = tab_Temp(i)
Next i
'ReDim preserveTa_Fld(UBound(Tab_Fld) - 1) '********
Ind = UBound(Tab_Fld)
ReDim Preserve Tab_Fld(Ind)
Else
'Si table_Fld <> 0 ajourter A temp
Indt = UBound(tab_Temp)
ReDim Preserve tab_Temp(Indt + IndFld)
For i = 1 To IndFld
Set tab_Temp(Indt + i) = Tab_Fld(i)
Next i
ReDim Tab_Fld(Indt + IndFld)
For i = 0 To (Indt + IndFld)
Set Tab_Fld(i) = tab_Temp(i)
Next i
End If
End Select
Inds = Inds + 1
ReDim Preserve Tab_Sortie(Inds)
ReDim tab_Temp(0)
Loop
'====================================
Set olApp = Nothing
Set nmsName = Nothing
Set fldFolder = Nothing
Set Tab_Fld(0) = Nothing
Set tab_Temp(0) = Nothing
End Sub
'*****************************************
Merci encore
