Macro : Lire une donnée sans ouvrir le fichier

Sub test()
Dim fich$, feuil$, Cell As Range
  fich = "D:\TestADO.xls"
  feuil = "feuil1"
  Set Cell = Range("A1")
  MsgBox GetValueWithADO(fich, feuil, Cell)
End Sub

Function GetValueWithADO(Classeur$, Feuille$, Cell As Range)
'renvoie la valeur de la cellule Cell de la feuille Feuille
'du classeur fermé Classeur
Dim RcdSet As Object
Dim strConn As String
Dim strCmd As String
Dim dummyBase As Range
  
  'prépare une "base de données" bidon pour la clause SELECT
  '(une entête fictive et une ligne de données)
  Set dummyBase = Cell.Resize(2)
  
  'prépare les commandes ADO et SQL
  strConn = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
                "Data Source=" & Classeur & ";" & _
                "Extended Properties=""Excel 8.0;HDR=No;IMEX=1;"";"
  strCmd = "SELECT * FROM [" & Feuille & "$" & dummyBase.Address(0, 0) & "]"
  
  'crée l'objet Recordset
  Set RcdSet = CreateObject("ADODB.Recordset")
  
  'va chercher l'info
  RcdSet.Open strCmd, strConn, 0, 1, 1 'adOpenForwardOnly, adLockReadOnly, adCmdText
  
  'et la renvoie
  GetValueWithADO = Application.Clean(RcdSet(0))
  'autre syntaxe possible
'  GetValueWithADO =Application.Clean(RcdSet.GetString(NumRows:=1))
  
  'nettoyage
  Set RcdSet = Nothing
End Function

Dim Chemin As String, Fich As String, Feuil As String, Cell As String, Result
'Si AA1 est une cellule vide
    Chemin = "D:\"
    Fich = "TestPasADO.xls"
    Feuil = "Feuil1"
    Cell = "$A$1"
    Range("AA1").Formula = "='" & Chemin & "[" & Fich & "]" & Feuil & "'!" & Cell
    Result = Range("AA1").Value
    Range("AA1").ClearContents
    MsgBox Result

ExtraireValeur = ExecuteExcel4Macro(Argument)

Option Explicit

Sub Essai()
    Extraction "En attente", "a.l@gmail.com"
    End Sub
    
Sub Extraction(NomDossier As String, Expediteur As String)
    Dim olApp As Outlook.Application
    Dim olSpace As Outlook.NameSpace
    Dim olFolder As Outlook.MAPIFolder
    Dim OLinbox As Outlook.MAPIFolder
    Dim olmail As Outlook.MailItem
    Dim pceJointe As Outlook.Attachment
    Dim MonBody As String, MonNum As String
    Dim y As Integer, x As Integer
    Dim nom As Variant
    Dim Argument As String
    Dim sDossier As String, sFichier As String, sFeuille As String
    Dim Valeurextraite As String
    
        
    
    Set olApp = New Outlook.Application
    Set olSpace = olApp.GetNamespace("MAPI")
    Set OLinbox = olSpace.GetDefaultFolder(olFolderInbox)
    Set olFolder = OLinbox.Folders(NomDossier)
 
 
 Dim Chemin As String, Fich As String, Feuil As String, Cell As String, Result

For Each olmail In olFolder.Items
        If olmail.SenderEmailAddress = Expediteur And _
            Not olmail.Attachments.Count = 0 Then
            

    
    
            For y = 1 To olmail.Attachments.Count
                 Set pceJointe = olmail.Attachments(y)
                 x = x + 1

                
                sDossier = ""
                sFichier = pceJointe
                sFeuille = "Feuil1"
                
                
                Valeurextraite = ExtraireValeur(sDossier, sFichier, sFeuille, "A1")

                pceJointe.SaveAsFile "C:\Users\Desktop\" & Valeurextraite & "-" & pceJointe
                Set pceJointe = Nothing
              
            Next y
        End If
        
    Next olmail


End Sub

Private Function ExtraireValeur(ByVal Dossier As String, ByVal Fichier As String, ByVal Feuille As String, ByVal Cellule As String)

Dim Argument As String
   
    Argument = "'" & Dossier & "[" & Fichier & "]" & Feuille & "'!" & "R1C1"
    ExtraireValeur = ExecuteExcel4Macro(Argument)
End Function

ExtraireValeur = ExecuteExcel4Macro(Argument)

'va chercher l'info
  RcdSet.Open strCmd, strConn, 0, 1, 1 'adOpenForwardOnly, adLockReadOnly, adCmdText