Ouverture fichier Excel - fermeture fichier - le fichier reste "utilisé"

Bonjour à tous,

Dans mon module Outlook je fais appel à un fichier excel, je l'ouvre et je fais 3 manipulations dessus, jusque là tout va bien.

Mon souci est que, pour une raison que j'ignore, lorsque je quitte mon fichier Excel, et que j'essaie de relancer la macro pour un autre mail, mon fichier est toujours repris comme "déjà utilisé par un autre programme", même chose si j'essaie de l'ouvrir par mon arborescence. Il y a donc quelque chose dans ce que j'ai écris qui fait que le fichier reste utilisé, même si je l'ai fermé, et même si je ferme Excel via les gestionnaire des tâches (là ça devient tordu mais si j'essaie alors de redémarrer mon PC il me dit qu'Excel est ouvert, alors que non, et que le gestionnaire des tâches ne me l'indique pas non plus).

J'ai pas mal épluché internet, essayé plusieurs choses, mais pour l'instant je n'ai pas encore trouvé de solution (probablement parce que je ne comprends pas ce qui se passe). Ca doit se produire via mon CreateObject ou dans l'Open du fichier, mais je ne trouve pas ce qui manque, et manifestement le set final à Nothing n'y change rien.

Pouvez-vous m'aider ?

Si le coeur vous en dit je cherche aussi comment créer un lien vers le mail que je viens de sauvegarder en cellule B (xExcelRange2) (mais ça serait du bonus, je continue de chercher )

Sub enregistrer()

Dim nomfichier As String
Dim Explorer As Outlook.Explorer
Dim NS As Outlook.NameSpace
Dim CurrentItem As Object
Dim Sender As Outlook.AddressEntry
Dim utilisateur As String, User_sans_espace As String
Dim LastRw As Long

Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xwb As Excel.Workbook
Dim xws As Excel.Worksheet
Dim xExcelRange As Excel.Range, xExcelRange2 As Excel.Range, xExcelRange3 As Excel.Range

Set NS = Application.GetNamespace("MAPI")
Set Explorer = Application.ActiveExplorer
utilisateur = NS.CurrentUser
User_sans_espace = Replace(NS.CurrentUser, " ", vbNullString)

xExcelFile = "C:\Users\" & User_sans_espace & "\adresse.xlsm"

If Explorer.Selection.Count Then

Set CurrentItem = Explorer.Selection(1)
Set Sender = CurrentItem.Sender

nomfichier = InputBox("Quel est le nom du candidat ?", "Enregistrer le CV de " & Sender)
If Not nomfichier = "" Then
CurrentItem.SaveAs ("C:\Users\" & User_sans_espace & "\adresse\CV de " & nomfichier & ".msg")

End If
End If

Set xExcelApp = CreateObject("Excel.Application")
Set xwb = xExcelApp.Workbooks.Open(xExcelFile)
Set xws = xwb.Sheets("Candidatures à traiter")
xws.Activate
xExcelApp.Visible = True

LastRw = Sheets("Candidatures à traiter").Cells(Rows.Count, 1).End(xlUp).Row
Set xExcelRange = xws.Range("A" & LastRw + 1)
Set xExcelRange2 = xws.Range("B" & LastRw + 1)
Set xExcelRange2 = xws.Range("D" & LastRw + 1)
If MsgBox("Souhaites-tu créer une nouvelle ligne pour ce candidat ?", vbOKCancel, "Nouveau candidat") = vbYes Then
xExcelRange.Value = Now

'xExcelRange2.Value = Lien (c'est ici que je cherche à insérer le lien vers le mail que je viens de sauvegarder

xExcelRange3.Value = nomfichier
End If

Set NS = Nothing
Set Explorer = Nothing
Set CurrentItem = Nothing
Set Sender = Nothing
Set xExcelApp = Nothing
Set xwb = Nothing
Set xws = Nothing
Set xExcelRange = Nothing
Set xExcelRange2 = Nothing
End Sub

Merci à tous pour votre aide précieuse.

Alors ! Voici où j'en suis :

Tout fonctionne à merveille, sauf si le fichier est déjà ouvert. Ca me génère une erreur (fichier déjà utilisé), je pensais pourtant être dans le bon, mais manifestement insuffisamment

Sub Enregistrer()

On Error GoTo erreur

Dim nomfichier As String
Dim Explorer As Outlook.Explorer
Dim NS As Outlook.NameSpace
Dim CurrentItem As Object
Dim Sender As Outlook.AddressEntry
Dim utilisateur As String, User_sans_espace As String
Dim LastRw As Long

Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xwb As Excel.Workbook
Dim xws As Excel.Worksheet
Dim xExcelRange As Excel.Range, xExcelRange2 As Excel.Range, xExcelRange3 As Excel.Range

Set NS = Application.GetNamespace("MAPI")
Set Explorer = Application.ActiveExplorer
utilisateur = NS.CurrentUser
User_sans_espace = Replace(NS.CurrentUser, " ", vbNullString)

xExcelFile = "C:\Users\" & User_sans_espace & "\fichier.xlsm"

If Explorer.Selection.Count Then

Set CurrentItem = Explorer.Selection(1)
Set Sender = CurrentItem.Sender

nomfichier = InputBox("Quel est le nom du candidat ?", "Enregistrer le CV de " & Sender, Sender)
If Not nomfichier = "" Then
CurrentItem.SaveAs ("C:\Users\" & User_sans_espace & "\fichier\CV de " & nomfichier & ".msg")

End If
End If

If MsgBox("Souhaites-tu créer une nouvelle ligne pour ce candidat ?", vbYesNo, "Nouveau candidat") = vbYes Then

On Error Resume Next
    Set xExcelApp = GetObject(, "Excel.Application")
    On Error GoTo erreur
    If xExcelApp Is Nothing Then
    Set xExcelApp = CreateObject("Excel.Application")
    End If

On Error Resume Next
    Set xwb = xExcelApp.Workbooks.Item(ExtractFileName(xExcelFile))
    On Error GoTo erreur

    If xwb Is Nothing Then
        Set xwb = xExcelApp.Workbooks.Open(xExcelFile)
    End If

Set xws = xwb.Sheets("Candidatures à traiter")
xExcelApp.Visible = True

LastRw = xws.Cells(Rows.Count, 1).End(xlUp).Row
With xws
.Range("A" & LastRw + 1).Value = Format(Now, "d mmmm yyyy hh:nn")
.Range("B" & LastRw + 1).Value = "CV reçu"
.Range("C" & LastRw + 1).Value = "Mail de candidature"
.Hyperlinks.Add Range("C" & LastRw + 1), Address:="C:\Users\" & User_sans_espace & "\fichier " & nomfichier & ".msg", ScreenTip:="Ouvrir le mail", TextToDisplay:="Mail de candidature"
.Range("D" & LastRw + 1).Value = nomfichier
End With

xExcelApp.Visible = True
'xwb.Close True
'xExcelApp.Quit

MsgBox "Le candidat est enregistré dans l'outil de recrutement"
End If

Set NS = Nothing
Set Explorer = Nothing
Set CurrentItem = Nothing
Set Sender = Nothing
Set xExcelApp = Nothing
Set xwb = Nothing
Set xws = Nothing
Set xExcelRange = Nothing
Set xExcelRange2 = Nothing

Exit Sub

erreur:  MsgBox (Err.Description)
End Sub

Public Function ExtractFileName(ByVal FilePath As String) As String
        ExtractFileName = Mid(FilePath, InStrRev(FilePath, "\") + 1)
End Function

Pourriez-vous m'indiquer ce qui coince ? Merci beaucoup.

Bonjour Lorence,

Je viens de tomber sur ce fil, avez-vous pu avancer depuis le 02/11 je l'espère

Mais pour moi votre erreur est normale puisqu'un fichier Excel déjà ouvert n'est qu'en lecture seule

A+

Bonjour Bruno,

Oui j'ai pu trouver comment y parvenir. Ca fonctionne maintenant.

D'ailleurs pour les éventuelles personnes qui atterriraient sur ce fil, voici la macro et les 3 fonctions qui vont avec :

Option Explicit
Option Compare Text

Sub Enregistrer()

On Error GoTo erreur

Dim nomfichier As String
Dim Explorer As Outlook.Explorer
Dim NS As Outlook.NameSpace
Dim CurrentItem As Object
Dim Sender As Outlook.AddressEntry
Dim utilisateur As String, User_sans_espace As String
Dim LastRw As Integer, LastRw2 As Integer
Dim xExcelFile As String
Dim xws As Excel.Worksheet
Dim xExcelRange As Excel.Range, xExcelRange2 As Excel.Range, xExcelRange3 As Excel.Range
Dim MailExpediteur As String
Dim objFolder As Outlook.Folder
Dim trouve As Boolean
Dim i As Integer
Dim appExcel As Object
Dim wb As Object
Dim xwl As Excel.Worksheet
Dim foundWorkbook As Workbook
Dim cheminFichier As String
Dim fichier As String
Dim fichierOuvert As Boolean
Dim fichierBXL As String, fichierWAL As String, Agence As String
Dim fichierBXLLocal As String, fichierWALLocal As String

Set NS = Application.GetNamespace("MAPI")
Set Explorer = Application.ActiveExplorer
utilisateur = NS.CurrentUser
User_sans_espace = Replace(NS.CurrentUser, " ", vbNullString)

fichierBXL = "https://adressesharepointdufichier
fichierWAL = "https://adressesharepointdufichier

'si un email est sélectionné on débute la procédure

If Explorer.Selection.Count Then

    Set CurrentItem = Explorer.Selection(1)
    Set Sender = CurrentItem.Sender
    MailExpediteur = Sender.Address
    nomfichier = InputBox("Quel est le nom du candidat ?", "Enregistrer le CV de " & Sender, Sender)
    Agence = MsgBox("C'est un candidat pour Bruxelles ?", vbYesNoCancel, "Choix de l'agence")

        If Agence = vbYes Then

            'on enregistre le CV dans le fichier CV de Bruxelles
            CurrentItem.SaveAs ("C:\Users\" & User_sans_espace & "\adressedufichier\CV de " & nomfichier & ".msg")

            ' on vérifie si Excel est déjà ouvert
            On Error Resume Next
            Set appExcel = GetObject(, "Excel.Application")
            ' Si Excel n'est pas ouvert, l'erreur va être 1 et on crée une nouvelle instance, sinon pas d'erreur = excel est ouvert
                If Err.Number <> 0 Then
                Set appExcel = CreateObject("Excel.Application")
                appExcel.Visible = False ' on n'affiche pas encore excel
                End If
            On Error GoTo erreur

    ' Convertit l'URL en chemin local
    fichierBXLLocal = ConvertirURLenCheminLocal(fichierBXL)

'    ' Vérifie si le fichier Excel est ouvert
'If EstFichierExcelOuvert(fichierBXLLocal) Then
'    'MsgBox "Le fichier est ouvert.", vbInformation
'    Set wb = appExcel.Workbooks(GetNomClasseurFromPath(fichierBXLLocal))
'Else
'    'MsgBox "Le fichier n'est pas ouvert, je l'ouvre.", vbInformation
'    Set wb = appExcel.Workbooks.Open(fichierBXL)
'End If

'on convertit le fichier en local

fichierWALLocal = ConvertirURLenCheminLocal(fichierWAL)

Dim wbBruxelles As Object
Dim wbWallonie As Object

On Error Resume Next
Set wbBruxelles = appExcel.Workbooks(GetNomClasseurFromPath(fichierBXLLocal))
Set wbWallonie = appExcel.Workbooks(GetNomClasseurFromPath(fichierWALLocal))
On Error GoTo 0

If Not wbBruxelles Is Nothing And Not wbWallonie Is Nothing Then
    ' Les deux fichiers sont ouverts. Active le classeur de Bruxelles.
    appExcel.Workbooks(GetNomClasseurFromPath(fichierBXLLocal)).Activate
    Set wb = appExcel.ActiveWorkbook
ElseIf Not wbBruxelles Is Nothing Then
    ' Le fichier Bruxelles est ouvert
    Set wb = wbBruxelles
Else
    ' Aucun des fichiers n'est ouvert, j'ouvre Bruxelles par défaut
    Set wb = appExcel.Workbooks.Open(fichierBXL)
End If

Set xws = wb.Sheets("Candidatures à traiter")
Set xwl = wb.Sheets("Listing des CV reçus")

LastRw = xws.Cells(xws.Rows.Count, 1).End(xlUp).Row
LastRw2 = xwl.Cells(xwl.Rows.Count, 1).End(xlUp).Row

'vérifier si le candidat est dans la liste rouge, si oui on sort sans sauvegarder

    ' Parcourir la colonne C pour vérifier si l'expéditeur est présent
    trouve = False
    For i = 1 To xwl.Cells(xwl.Rows.Count, "C").End(-4162).Row ' -4162 correspond à xlUp
        If LCase(Trim(xwl.Cells(i, "C").Value)) = LCase(Trim(nomfichier)) And xwl.Cells(i, "F").Value = "Oui" Then
            trouve = True
            Exit For
        End If
    Next i

    If trouve Then
    MsgBox "Le candidat est dans la liste rouge, j'annule son enregistrement."
    'wb.Close SaveChanges:=False
    'appExcel.Quit
    Set appExcel = Nothing
    Exit Sub
    End If

'si le candidat n'est pas sur liste rouge on l'enregistre

With xws
.Range("A" & LastRw + 1).Value = Format(Now, "d mmmm yyyy hh:nn")
.Range("B" & LastRw + 1).Value = "CV reçu"
.Range("C" & LastRw + 1).Hyperlinks.Add xws.Range("C" & LastRw + 1), Address:="C:\Users\" & User_sans_espace & "\adressedudossier\CV de " & nomfichier & ".msg", ScreenTip:="Ouvrir le mail", TextToDisplay:="Mail de candidature"
.Range("D" & LastRw + 1).Value = nomfichier
.Range("G" & LastRw + 1).Value = MailExpediteur
End With

With xwl
.Range("A" & LastRw2 + 1).Value = Format(Now, "d mmmm yyyy hh:nn")
.Range("B" & LastRw2 + 1).Hyperlinks.Add xwl.Range("B" & LastRw2 + 1), Address:="C:\Users\" & User_sans_espace & "\adressedudossier\CV de " & nomfichier & ".msg", ScreenTip:="Ouvrir le mail", TextToDisplay:="Mail de candidature"
.Range("C" & LastRw2 + 1).Value = nomfichier
.Range("D" & LastRw2 + 1).Value = MailExpediteur
End With

'wb.Close True
'appExcel.Quit
MsgBox "Le candidat est enregistré dans l'outil de recrutement de Bruxelles"
appExcel.Visible = True

ElseIf Agence = vbNo Then

            'on enregistre le CV dans le fichier CV de la Wallonie
            CurrentItem.SaveAs ("C:\Users\" & User_sans_espace & "\adressedossier\CV de " & nomfichier & ".msg")

            ' on vérifie si Excel est déjà ouvert
            On Error Resume Next
            Set appExcel = GetObject(, "Excel.Application")
            ' Si Excel n'est pas ouvert, l'erreur va être 1 et on crée une nouvelle instance, sinon pas d'erreur = excel est ouvert
                If Err.Number <> 0 Then
                Set appExcel = CreateObject("Excel.Application")
                appExcel.Visible = False ' on n'affiche pas encore excel
                End If
            On Error GoTo erreur

    ' Convertit l'URL en chemin local
    fichierWALLocal = ConvertirURLenCheminLocal(fichierWAL)

'convertir le fichier en local

fichierBXLLocal = ConvertirURLenCheminLocal(fichierBXL)

On Error Resume Next
Set wbBruxelles = appExcel.Workbooks(GetNomClasseurFromPath(fichierBXLLocal))
Set wbWallonie = appExcel.Workbooks(GetNomClasseurFromPath(fichierWALLocal))
On Error GoTo 0

If Not wbBruxelles Is Nothing And Not wbWallonie Is Nothing Then
    ' Les deux fichiers sont ouverts. Active le classeur de la Wallonie.
    appExcel.Workbooks(GetNomClasseurFromPath(fichierWALLocal)).Activate
    Set wb = appExcel.ActiveWorkbook
ElseIf Not wbWallonie Is Nothing Then
    ' Le fichier Wallonie est ouvert
    Set wb = wbWallonie
Else
    ' Aucun des fichiers n'est ouvert, j'ouvre la Wallonie par défaut
    Set wb = appExcel.Workbooks.Open(fichierWAL)
End If

Set xws = wb.Sheets("Candidatures à traiter")
Set xwl = wb.Sheets("Listing des CV reçus")

LastRw = xws.Cells(xws.Rows.Count, 1).End(xlUp).Row
LastRw2 = xwl.Cells(xwl.Rows.Count, 1).End(xlUp).Row

'vérifier si le candidat est dans la liste rouge, si oui on sort sans sauvegarder

    ' Parcourir la colonne C pour vérifier si l'expéditeur est présent
    trouve = False
    For i = 1 To xwl.Cells(xwl.Rows.Count, "C").End(-4162).Row ' -4162 correspond à xlUp
        If LCase(Trim(xwl.Cells(i, "C").Value)) = LCase(Trim(nomfichier)) And xwl.Cells(i, "F").Value = "Oui" Then
            trouve = True
            Exit For
        End If
    Next i

    If trouve Then
    MsgBox "Le candidat est dans la liste rouge, j'annule son enregistrement."
    'wb.Close SaveChanges:=False
    'appExcel.Quit
    Set appExcel = Nothing
    Exit Sub
    End If

'si le travailleur n'est pas sur liste rouge on l'enregistre

With xws
.Range("A" & LastRw + 1).Value = Format(Now, "d mmmm yyyy hh:nn")
.Range("B" & LastRw + 1).Value = "CV reçu"
.Range("C" & LastRw + 1).Hyperlinks.Add xws.Range("C" & LastRw + 1), Address:="C:\Users\" & User_sans_espace & "\Maison-Net\Maison-Net - Documents\1. Gestion agences Maison Net\RECRUTEMENT\Wallonie/CV\CV de " & nomfichier & ".msg", ScreenTip:="Ouvrir le mail", TextToDisplay:="Mail de candidature"
.Range("D" & LastRw + 1).Value = nomfichier
.Range("G" & LastRw + 1).Value = MailExpediteur
End With

With xwl
.Range("A" & LastRw2 + 1).Value = Format(Now, "d mmmm yyyy hh:nn")
.Range("B" & LastRw2 + 1).Hyperlinks.Add xwl.Range("B" & LastRw2 + 1), Address:="C:\Users\" & User_sans_espace & "\adressedudossier\CV de " & nomfichier & ".msg", ScreenTip:="Ouvrir le mail", TextToDisplay:="Mail de candidature"
.Range("C" & LastRw2 + 1).Value = nomfichier
.Range("D" & LastRw2 + 1).Value = MailExpediteur
End With

'wb.Close True
'appExcel.Quit

MsgBox "Le candidat est enregistré dans l'outil de recrutement de la Wallonie"
appExcel.Visible = True

ElseIf Agence = vbCancel Then MsgBox "Enregistrement annulé": Exit Sub

End If

Set objFolder = Nothing
Set NS = Nothing
Set Explorer = Nothing
Set CurrentItem = Nothing
Set Sender = Nothing
Set xwl = Nothing
Set xws = Nothing
Set xExcelRange = Nothing
Set xExcelRange2 = Nothing
Set appExcel = Nothing
Set wb = Nothing

End If

Exit Sub

erreur:  MsgBox (Err.Description)
End Sub

Function ConvertirURLenCheminLocal(url As String) As String
    ' Remplacez les caractères spéciaux dans l'URL
    ConvertirURLenCheminLocal = Replace(url, "%20", " ")
End Function

Function EstFichierExcelOuvert(cheminFichier As String) As Boolean
    Dim GetObjectExcel As Object

    On Error Resume Next
    ' Tente d'obtenir une référence au fichier Excel
    Set GetObjectExcel = GetObject(, "Excel.Application")
    On Error GoTo 0

    ' Vérifie si le fichier Excel est ouvert
    If Not GetObjectExcel Is Nothing Then
        ' Vérifie si le classeur est ouvert en comparant le nom du classeur
        If Not GetObjectExcel.ActiveWorkbook Is Nothing Then
            If StrComp(GetObjectExcel.ActiveWorkbook.Name, GetNomClasseurFromPath(cheminFichier), vbTextCompare) = 0 Then
                EstFichierExcelOuvert = True
            End If
        End If
        ' Ferme l'application Excel
        'GetObjectExcel.Application.Quit
    End If
End Function

Function GetNomClasseurFromPath(cheminFichier As String) As String
    ' Récupère le nom du classeur à partir du chemin du fichier
    Dim elementsChemin() As String
    elementsChemin = Split(cheminFichier, "/")
    GetNomClasseurFromPath = elementsChemin(UBound(elementsChemin))
End Function

Bonne journée ;)

Bonjour Lorence et merci pour ce partage de solution

Bonne journée