Fermeture automatique classeur excel avec alarme

Télécharger le projet
Commenter

Description

La fermeture automatique d'un classeur Excel inactif laissé ouvert est précédée d'un message affichant en premier plan un décompte des X dernières secondes et d'un avertissement sonore (fichier Wav ou Bip/seconde).
=> Détection de l'activité spécifique au classeur par : SelectionChange
=> Bip par : APIBeep Lib "kernel32"
=> Son par : PlaySound Lib "winmm.dll"
=> Premier plan : SetWindowPos Lib "user32"
Tout est dans le fichier Tempo.zip
=> fichier Wav = Beethoven.Wav (à copier sous C:\)
Ce fichier faisant 1,8Mo je ne peux le joindre ici. Je vous l'adresserai par mail sur demande

Source / Exemple : 


'Ajouter dans Thisworbook
'************************
Private Sub Workbook_Open()
StartTempo
End Sub
'----------------------
Private Sub Workbook_BeforeClose(Cancel As Boolean)
StopTempo
End Sub
'----------------------

'Ajouter dans chaque feuille
'***************************
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Relancer
End Sub
'----------------------

'Ajouter dans la Form "Alerter"
'******************************
'PROPRIETE => ShowModal = False
'BOUTON => Name = Encore + Caption = Cliquer pour Continuer
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()
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
End Sub
'----------------------
Private Sub Encore_Click()
Relancer
End Sub
'----------------------

'Ajouter dans le module "TempoWav"
'*********************************
Option Explicit
Public Tp180s As Variant
Public MemData As Etat  '(S Nikator)
'----------------------
Type Etat               '(S Nikator)
Mem1 As Boolean
Mem2 As Boolean
End Type
'----------------------
Private Const SND_ASYNC = &H1                   
Private Const SND_FILENAME = &H20000            
Private Const SND_PURGE = &H40
'----------------------
Private Declare Function APIBeep Lib "kernel32" Alias "Beep" _
         (ByVal dwFreq As Long, ByVal dwDuration As Long) As Long
Private Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
'----------------------
Sub StartTempo()
Tp180s = Now + TimeValue("00:03:00")            
Application.OnTime Tp180s, "AlerteFin"          
MemData.Mem1 = True                       
End Sub
'----------------------
Sub AlerteFin()
MemData.Mem1 = False
MemData.Mem2 = True
Alerter.Show
Décompter                                      
End Sub
'----------------------
Sub Décompter()
Dim T As Long
OuvreWav
Application.ScreenUpdating = True
Dim i
For i = 1 To 12 '2s ajoutées pour le temps du chargement du Wav
    If MemData.Mem2 = False Then Exit Sub
    Application.Wait (Now + TimeValue("00:00:01"))
    DoEvents
    T = 12 - i                              
    Alerter.Caption = " Fermeture dans " & T & " Secondes"
    'Beep 'A décommenter si Bip à chaque seconde au lieu de Wav
Next i
MemData.Mem1 = False                          
MemData.Mem2 = False                          
Alerter.Caption = "Fermeture dans 12 Secondes"'mettre 10 pour Beep
Alerter.Hide                                 
Application.DisplayAlerts = False            
WbC = Workbooks.Count                       
If WbC < 2 Then                             
    ThisWorkbook.Save   '(S Nikator)           
    Application.Quit                        
Else                                         
    ThisWorkbook.Save   '(S Nikator)              
    ThisWorkbook.Close  '(S Nikator)          
End If
End Sub
'----------------------
Sub Relancer()
Alerter.Hide
FermeWav
On Error Resume Next
Application.OnTime Tp180s, "AlerteFin", , False 
MemData.Mem1 = False                              
MemData.Mem2 = False                              
StartTempo                                      
End Sub
'----------------------
Sub StopTempo()
On Error Resume Next
Application.OnTime Tp180s, "AlerteFin", , False  
MemData.Mem1 = False                              
MemData.Mem2 = False                             
End Sub
'----------------------
Sub OuvreWav()
PlaySound "c:\Beethoven.wav", ByVal 0&, SND_FILENAME Or SND_ASYNC
End Sub
'----------------------
Sub FermeWav()
PlaySound vbNullString, ByVal 0&, SND_PURGE
End Sub
'----------------------

Conclusion :


A l'ouverture une tempo de 3mn est activée, et relancée lors de toute action dans une feuille du classeur. Au bout de 3mn d'inactivité, le décompte des 10 dernières secondes s'affiche et le fichier Wav est joué (ou les Bip déclenchés). Un bouton permet de reprendre la main avant que le fichier ne se sauvegarde et ne se ferme.
Télécharger le projet

Codes Sources

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)