Ouverture fichier Excel - fermeture fichier - le fichier reste "utilisé"
L
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 SubMerci à tous pour votre aide précieuse.
L
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 FunctionPourriez-vous m'indiquer ce qui coince ? Merci beaucoup.
Invité
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+
L
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 FunctionBonne journée ;)