Fermeture automatique d'excel inactif

Commenter

Contenu du snippet

Ferme et sauve automatiquement un fichier source Excel (exemple, en réseau et mode non partagé)au bout d'un temps d'inactivité (ici 3mn)

Source / Exemple : 


'Dans le fichier source

'Ajouter dans ThisWorkbook
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopAutoClose
End Sub

'Ajouter un Module
Option Explicit
Public Tp10, Tp180, WbC As Variant
Private Declare Function APIBeep Lib "kernel32" Alias "Beep" _
         (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
'************************************************************************************

Sub Beeper1()
'=> Fréquence moyenne du Beep

APIBeep 500, 150
End Sub
'************************************************************************************

Sub Beeper2()
'=> Fréquence basse du Beep

APIBeep 200, 150
End Sub
'************************************************************************************

Sub StartTempo()
'=> Lancement de la durée d'accès libre (3 minutes avant alerte de relance)

Tp180 = Now + TimeValue("00:03:00")             'définit la durée de 180 secondes avant de lancer la prodédure de fermeture automatique
Application.OnTime Tp180, "AlerteFin"           'appelle la procédure de fermeture automatique
MemData.Mem1.Value = "1"                        'tempo Tp180 activée
End Sub
'************************************************************************************

Sub AlerteFin()
'=> Message de Relance (Arrêt Automatique engagé dans les 10 secondes)

MemData.Mem1.Value = "0"                        'tempo Tp180 échue
MemData.Mem2.Value = Date                       'initialisation du point de comptage par valeur de date
MemData.Mem3 = "1"                              'tempo Tp10 activée
CountDown                                       'lancement du comptage des 10 dernières secondes
End Sub
'************************************************************************************

Sub CountDown()
'=> Sauvegarde de Fermeture du Classeur dans 10 secondes...

'Application.ScreenUpdating = False
AlerteLS.Show                                   'affichage du temps restant et du bouton de relance
Tp10 = Now + TimeValue("00:00:01")
Dim Tp0, Tp1 As Date                            'format Date
Tp0 = CDate(MemData.Mem2.Value)                 'reprise du temps écoulé
Tp1 = Tp0 + 1                                   'temps restant à courrir = temps écoulé + une seconde
If Tp1 < Date + 11 Then                         'si temps restant à courrir < 11 secondes
    Application.ScreenUpdating = False
    MemData.Mem2.Value = Tp1                    'réinitialisation du temps écoulé
    Application.OnTime Tp10, "CountDown"        'rebouclage après une seconde
    Dim T As Long                               'format Long
    T = ((Date + 10) - Tp0) - 1                 'nombre de secondes restant
    Alerte.Caption = " Fermeture dans " & T & " Secondes"
    
    'Options de l'alerte sonore avant fermeture
    '******************************************
     'Beep décommenté
        '=> Son Windows par défaut pour tout le décompte
     'If > Beeper1 ET If < Beeper2 décommentés
        '=> Son 1, suivi du Son 2 les 3 dernières secondes
    
    Beep                                         'Son Windows : commenter If > Beeper1 ET If < Beeper2
    'If T > 3 Then Beeper1                       'Son Médium : commenter Beep
    'If T < 4 Then Beeper2                       'Son Grave  : commenter Beep

Else                                             'si les 10 secondes sont écoulées
    MemData.Mem2 = "0"                          'RAZ point de comptage
    MemData.Mem3 = "0"                          'CountDown : tempo Tp10 échue
    Alerte.Hide                                 'ferme l'affichage
    Application.DisplayAlerts = False           'inhibe le message d'enregistrement
    WbC = Workbooks.Count                       'compte les classeurs ouverts
    If WbC < 2 Then                             'si aucun classeur ouvert
        Workbooks("nom du fichier source").Save 'enregistre le classeur
        Application.Quit                        'ferme Excel
    Else                                        'si d'autres classeurs ouverts
        Workbooks("Nom du fichier source").Save 'enregistre le classeur
        Workbooks("Nom du fichier source").Close 'ferme seulement le classeur
    End If
End If
End Sub
'************************************************************************************

Sub Relancer()
'=> Arrêt du processus automatique de fermeture et relance

On Error Resume Next
Application.OnTime Tp180, "AlerteFin", , False  'arrêt de AlerteFin : tempo Tp180
Application.OnTime Tp10, "CountDown", , False   'arrêt de CountDown : tempo Tp10
If MemData.Mem3 = "1" Then Alerte.Hide          'ferme l'affichage si tempo Tp10 non échue
MemData.Mem1 = "0"                              'tempo Tp180 échue
MemData.Mem2 = "0"                              'RAZ point de comptage
MemData.Mem3 = "0"                              'CountDown : tempo Tp10 échue
StartTempo                                      'engage la relance
End Sub
'************************************************************************************

Sub StopAutoClose()
'=> Arrêt du processus automatique de fermeture
On Error Resume Next
Application.OnTime Tp180, "AlerteFin", , False  'arrêt de AlerteFin : tempo Tp180
Application.OnTime Tp10, "CountDown", , False   'arrêt de CountDown : tempo Tp10
If MemData.Mem3 = "1" Then Alerte.Hide          'ferme l'affichage si tempo Tp10 non échue
MemData.Mem1 = "0"                              'tempo Tp180 échue
MemData.Mem2 = "0"                              'RAZ point de comptage
MemData.Mem3 = "0"                              'CountDown : tempo Tp10 échue
End Sub
'************************************************************************************

'Ajouter une Form nommée MemData contenant 3 Textbox Mem1, Mem2, Mem3

'Ajouter une Form nommée "Alerte", Caption=" Fermeture dans 10 Secondes...", 
'contenant un bouton (nom ="Encore", Caption =CLIQUER POUR CONTINUER" et le code : 

Private Const HWND_TOPMOST As Long = (-1)
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOSIZE As Long = &H1
'************************************************************************************
Private Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
'************************************************************************************
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, _
    ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, _
    ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
'************************************************************************************

Private Sub UserForm_Activate()
'=> Affiche la UserForm au premier plan

Dim hwnd As Long
hwnd = FindWindowA("Thunder" & IIf(Application.VERSION Like "8*", "X", _
    "D") & "Frame", Me.Caption)
Call SetWindowPos(hwnd, HWND_TOPMOST, &H0, &H0, &H0, &H0, _
    SWP_NOMOVE Or SWP_NOSIZE)
'************************************************************************************

Private Sub Encore_Click()
'=> Relance la temporistaion de fermeture automatique

Relancer
End Sub
'************************************************************************************

'Ajouter dans chaque feuille

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'=>En cas de changement dans la feuille

Relancer    'lance la temporisation de fermeture automatique
End Sub

Conclusion :


Un fichier au reseau et non partagé "oublié" ouvert ne paralysera plus les autres utilisateurs... puisqu'il se fermera automatiquement après sa procédure d'alerte

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (CerberusPau)