Detection Fermeture Excel VBA
Bonjour à tous et à toutes
J'ai créer un programme VBA qui stocke des données dans un fichier Excel créer spécialement pour. J'aimerais que suite à la fermeture de ce fichier temporaire, celui ci soit supprimer du dossier Temp qu'il soit enregistrer ou non. J'ai vu qu'il existait la procédure Before_Close, mais en essayant de le mettre en place, il s’applique juste sur le fichier Excel de base. Comment faire s'il vous pait ?
Merci d'avance pour votre aide et votre temps.
CDT
SaintYor
Bonjour et bienvenue,
Je ne sais pas ce que tu as mis dans ton Before_Close mais avec ça,
Kill "C:\TEMP\mon_fichier.xlsx"
Le fichier temporaire va se supprimer.
A+
Bonjour et merci
Est ce que cette action va s'effectuer quand je vais fermer mon fichier temporaire ? parce que le code Before_Close est dans le fichier source.
Merci d'avance
SaintYor
Je n'ai peut-être pas bien saisi l'utilisation.
Ce que j'ai compris :
Quand tu ferme le dossier source, le fichier temporaire doit etre supprimé.
Si c'est le cas, dans la précédure before_close de ton fichier source tu mets le code
Kill "C:\TEMP\mon_fichier.xlsx"
où "mon_fichier" correspond a ton fichier temporaire.
Si tu souhaite que l'action se fasse quand le fichier temporaire se ferme, c'est plus compliqué a moin que tu puisse ne pas autoriser la sauvegarde du fichier temporaire.
En effet, c'est quand je ferme mon fichier temporaire qu'il est effacé . Donc c'est plus le second cas que tu décris.
Je ne sais même pas si c'est possible, tu peux donner plus d'info pour savoir comment ce fichier temporaire est créé ?
Imaginons que c'est possible :
Je te fais un fichier et je te l'envoi pour que tu le test, mais pour l'envoyer je dois l'enregistrer et le fermer et du coup, ??? si je le ferme il se supprime.
Je créer un fichier avec ceci :
tempFile = Environ("temp") & "\TempFile.xlsx"
Dim xlApp As Object
Set xlApp = New Excel.Application
xlApp.Visible = True
xlApp.Workbooks.Add
xlApp.Workbooks(1).SaveAs tempFile
xlApp.ActiveSheet.Cells(1, 1).Value = "Référence"
xlApp.ActiveSheet.Cells(1, 2).Value = "Observations"
xlApp.ActiveSheet.Cells(1, 3).Value = "Items"
et avec des boucles je remplie le fichier tempfile qui est un excel application
Voici tout le code :
Public tempFile As String
Sub Verification_Carnet_Ferrure()
Dim DossierPlans As String
'Définit le répertoire pour débuter la recherche de fichiers.
'(Attention à ne pas indiquer un répertoire qu contient trop de sous-dossiers ou de
'fichiers, sinon le temps de traitement va être très long).
DossierPlans = "Nom dossier des plans"
'Appelle la procédure de recherche des fichiers
Verification_Finale DossierPlans
'Ajuste la largeur des colonnes A:E en fonction du contenu des cellules.
End Sub
Sub Verification_Finale(Repertoire As String)
'
'Nécessite d'activer la référence "Microsoft Scripting RunTime"
'Dans l'éditeur de macros (Alt+F11):
'Menu Outils
'Références
'Cochez la ligne "Microsoft Scripting RunTime".
'Cliquez sur le bouton OK pour valider.
Dim Fso As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim monfichier As String
Dim PrecedentFileType As String
Dim i As Long
Dim ListePlanFerrures() As String
Dim ListeIndice() As String
Dim indiceFichier As String
Dim ListeIndiceFichier() As String
Dim Nom_Fichier_Base As String
Set Fso = CreateObject("Scripting.FileSystemObject")
Set SourceFolder = Fso.GetFolder(Repertoire)
tempFile = Environ("temp") & "\TempFile.xlsx"
Nom_Fichier_Base = ThisWorkbook.Name
i = 0
'Boucle sur tous les fichiers du répertoire
For Each FileItem In SourceFolder.Files
'pas eu le choix de mettre Microsoft Edge PDF Document pour pouvoir intégrer les PDF, a voir si cela fonctionne avec tout les postes
If FileItem.Type = "Fichier dwg" Or FileItem.Type = "Fichier DWG" Or FileItem.Type = "Microsoft Edge PDF Document" Or FileItem.Type = "*pdf*" Then
monfichier = Split(FileItem.Name, ".")(0)
If InStr(monfichier, "-") > 0 Then
indiceFichier = Split(monfichier, "-")(1)
monfichier = Split(monfichier, "-")(0)
If i < 1 Then
ReDim Preserve ListePlanFerrures(i)
ReDim Preserve ListeIndiceFichier(i)
ListePlanFerrures(i) = monfichier
ListeIndiceFichier(i) = indiceFichier
i = i + 1
End If
End If
If monfichier <> ListePlanFerrures(i - 1) Then
'Inscrit le nom du fichier dans la Variable
ReDim Preserve ListePlanFerrures(i)
ReDim Preserve ListeIndiceFichier(i)
ListePlanFerrures(i) = monfichier
ListeIndiceFichier(i) = indiceFichier
i = i + 1
End If
End If
Next FileItem
'toute la partie précédente recense les plans DWG d'un fichier et récolte les indices de révisions
'------------------------------------------- Fin partie 1 -----------------------------
' Cette partie suivante récupère la liste précédente de plans et la compare a une nomenclature et s'il y a des différence, les stocks dans le fichier temporaire
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim n As Integer
Dim p As Integer
Dim q As Integer
Dim r As Integer
Dim s As Integer
Dim t As Integer
Dim Colonne_Item() As Variant
Dim DebutFerrures As Integer
Dim Finferrures As Integer
Dim FinPlans As Integer
Dim ListeFerrures() As String
Dim ListeIndiceFerrures() As String
Dim Liste_Item() As String
Dim LongListePlanFerrures As Integer
Dim LongListeFerrures As Integer
Dim Numero_Ligne_Piece() As Integer
Dim QuantitesFerrures() As Variant
Dim xlApp As Object
Set xlApp = New Excel.Application
xlApp.Visible = True
xlApp.Workbooks.Add
xlApp.Workbooks(1).SaveAs tempFile
xlApp.ActiveSheet.Cells(1, 1).Value = "Référence"
xlApp.ActiveSheet.Cells(1, 2).Value = "Observations"
xlApp.ActiveSheet.Cells(1, 3).Value = "Items"
'Pour adaptation dans futur carnet de ferrure Nommer case et la selectionner
Workbooks(Nom_Fichier_Base).Sheets("Nomenclature").Range("Deb_colonne_ref").Activate
DebutFerrures = ActiveCell.Row
Finferrures = ActiveWorkbook.Sheets("Nomenclature").Range("Der_ligne_Ferr").Row
'Création d'un nouveau fichier avec les colonnes qui vont bien et possibilité de l'enregistrer.
n = 0
For k = 0 To Finferrures - DebutFerrures
If ActiveCell.Value = 0 Then
ActiveCell.Offset(1, 0).Activate
ElseIf ActiveCell.Value = ActiveCell.Offset(-1, 0).Value Then
ActiveCell.Offset(1, 0).Activate
ElseIf InStr(1, ActiveCell.Value, "#") > 0 Or InStr(1, ActiveCell.Value, "Coefficient") > 0 Then
ActiveCell.Offset(1, 0).Activate
ElseIf ActiveCell.Offset(0, 6).Value = "" Then
ActiveCell.Offset(1, 0).Activate
Else
ReDim Preserve ListeFerrures(n)
ReDim Preserve QuantitesFerrures(n)
ReDim Preserve ListeIndiceFerrures(n)
ReDim Preserve Numero_Ligne_Piece(n)
ListeFerrures(n) = ActiveCell.Value
QuantitesFerrures(n) = ActiveCell.Offset(0, 8).Value
ListeIndiceFerrures(n) = ActiveCell.Offset(0, 7).Value
Numero_Ligne_Piece(n) = ActiveCell.Row
n = n + 1
ActiveCell.Offset(1, 0).Activate
End If
Next
xlApp.Cells(1, 1).Activate
LongListePlanFerrures = UBound(ListePlanFerrures)
LongListeFerrures = UBound(ListeFerrures)
i = 2
For m = 0 To LongListePlanFerrures
For n = 0 To LongListeFerrures
If ListePlanFerrures(m) = ListeFerrures(n) Then
If QuantitesFerrures(n) = 0 Then
xlApp.Cells(i, 1) = "'" & ListePlanFerrures(m)
xlApp.Cells(i, 2) = "Quantité nulle"
i = i + 1
Exit For
ElseIf ListeIndiceFerrures(n) <> ListeIndiceFichier(m) Then
xlApp.Cells(i, 1) = "'" & ListePlanFerrures(m)
xlApp.Cells(i, 2) = "Indice Différent entre Nomenclature et Fichier"
i = i + 1
ActiveSheet.Cells(Numero_Ligne_Piece(n), 27).Activate
r = 0
For q = 1 To (ActiveSheet.Range("Fin_Colonne_item").Column - ActiveSheet.Cells(Numero_Ligne_Piece(n), 27).Column)
If ActiveCell.Offset(0, q).Value <> "" Then
ReDim Preserve Colonne_Item(r)
Colonne_Item(r) = ActiveCell.Offset(0, q).Column
r = r + 1
End If
Next
t = 0
For s = 0 To UBound(Colonne_Item)
ReDim Preserve Liste_Item(t)
Liste_Item(t) = ActiveSheet.Range("Impression_des_titres").Cells(1, Colonne_Item(s))
t = t + 1
Next
xlApp.Cells(i - 1, 3).Value = Join(Liste_Item, ", ")
Exit For
End If
Exit For
End If
Next
If n > LongListeFerrures Then
xlApp.Cells(i, 1) = "'" & ListePlanFerrures(m)
xlApp.Cells(i, 2) = "Pas Présent dans Carnet de Ferrures"
i = i + 1
End If
Next
xlApp.Range("A:E").Columns.AutoFit
MsgBox "Terminer ?"
Workbooks(Nom_Fichier_Base).Sheets("Nomenclature").Range("Deb_colonne_ref").Activate
'Workbook_BeforeClose
End Sub
Désolé, il est très long mais je ne suis pas codeur de base j’optimise que très peu
CDT
SaintYor
Il y a une raison a vouloir l'enregistrer en Temp ?
sinon vire simplement la ligne
xlApp.Workbooks(1).SaveAs tempFile
'et tempFile = Environ("temp") & "\TempFile.xlsx"
Edit : Je n'avais pas vu ton 2eme message, je regarde ça
Alors comme mon dernier message, si tu n'as pas besoin de l'enregistrer, tu peux retirer la ligne au niveau de l'enregistrement ".SaveAs"
Tu as aussi cette version puisque tu as une question à la fin de ta procedure:
Remplace :
MsgBox "Terminer ?"
Par :
If MsgBox("Veux-tu supprimer le fichier temporaire ?", vbYesNo, "Terminé ?") = vbYes Then
xlApp.Application.DisplayAlerts = False
xlApp.ActiveWorkbook.Close True
xlApp.Quit
Kill tempFile
End If
Traduction, a la fin de ta macro quand tu auras le message "Veux-tu supprimer le fichier temporaire ?"
Si tu met Oui => ça ferme ton fichier temporaire et le supprime dans la foulée
Si non, le fichier temporaire reste
Mais a ma connaissance, il ne sera pas possible de dire a une macro contenu dans le fichier source qu'a la fermeture du fichier temporaire, il doit etre supprimé.
Merci pour ce retour.
C'est une bonne alternative. J'avais mis la Msgbox terminer ? à la fin pour me faire un point d’arrêt facilement visible mais ça pourrait le faire
Merci encore
CDT
Sinon est il possible de faire en sorte que le ficheir tempFile soit supprimer du temp apres enregistrer sous si enregistrer sous il y a ?
Mais la macro sera dans ton fichier source et non dans le fichier temporaire ce qui revient a mon 1er message avec
Kill "C:\TEMP\mon_fichier.xlsx"
A la différence que ce n'est plus un BeforeClose qu'on utilisera mais un AfterSave.
A moins que quelqu'un d'autre a une idée ? je seche
Bonjour SaintYor, Geof52,
Pourquoi ne pas fermer directement le fichier temporaire par le premier fichier. Lorsque cela sera nécessaire.
Voir ci-dessous. Dans un module2 il existe le code newXL ouvrant la nouvelle instance d'Excel incluant le fichier temporaire.
Sur la premier fichier le Range A1 (ou autre) va indiquer par le chiffre 2 (ou autre) que le fichier temporaire est créé puis ouvert.
Public tempFile
Dim xlApp As Object
Sub newXL()
tempFile = Environ("temp") & "\TempFileEssai.xlsx"
Range("A1") = 2
Set xlApp = New Excel.Application
xlApp.Visible = True
xlApp.Workbooks.Add
xlApp.Workbooks(1).SaveAs tempFile
End Sub
Sub Clore()
xlApp.DisplayAlerts = False
xlApp.Workbooks(1).Close
Kill tempFile
xlApp.Quit
End Sub
Aussi, sur le premier fichier un événement sur la cellule A1 est inscrit. Par le code ci-dessous.
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" And Range("A1") = 1 Then
Module2.Clore
End If
End Sub
Ainsi lorsque est tapé ici en A1 le chiffre 1, le fichier temporaire est supprimé et la 2ième instance d'Excel est fermé.
Cela peut se faire aussi par un bouton sur le 1ier fichier.