Liaison Excel outlook Vba

[aristote67]

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