Problème avec croix fermeture fichier

Version imprimable

Bonjour à tous,

J'ai mis en place un code qui empêche l'utilisateur de fermer le classeur à l'aide de la croix située en haut à droite de l'écran.
Pour clore le classeur il doit cliquer sur un bouton spécifique.

Le problème est que si il clique sur la croix, ma barre de menus disparait et il n'est plus possible de fermer le classeur, puisque le bouton de fermeture se situe dans cette barre de menus.

Pouvez-vous m'apporter une explication ou une solution s'il vous plait ?
Merci par avance

Mon bouton est associé à ce module.
Code:

1 2 3 4 5 6 Sub fermerClasseur() ThisWorkbook.AutoriserFermeture = True ThisWorkbook.Save ThisWorkbook.Close End Sub
Dans ThisWorkBook_BeforeClose
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 Public AutoriserFermeture As Boolean Private Sub WorkBook_BeforeClose(Cancel As Boolean) Dim cmdb As CommandBar Supp_Cbar For Each cmdb In Application.CommandBars cmdb.Enabled = True Next cmdb With Application .DisplayFullScreen = False .CommandBars("Worksheet Menu Bar").Enabled = True .CommandBars("Standard").Visible = True .CommandBars("Formatting").Visible = True .CommandBars("Visual Basic").Visible = True .DisplayStatusBar = True .DisplayFormulaBar = True End With With ActiveWindow .DisplayHeadings = True .Zoom = 100 End With Cancel = Not AutoriserFermeture Application.Quit End Sub

Empêcher croix fermeture

Bonjour Nec14, Bonjour le Forum

Pour ma part, j'utilise cette solution en 3 parties

1 - Dans l'objet Thisworkbook

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Quitter As Boolean
 
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not Quitter Then
    MsgBox "Veuillez utiliser le bouton Quitter"
    Cancel = True
End If
End Sub
 
Public Sub Fermeture()
 
Call EnableSystemMenu
 
Quitter = True
 
If MsgBox("Voulez-vous enregistrer ce fichier ?", vbYesNo) = vbYes Then ThisWorkbook.Save
 
Application.DisplayAlerts = False
 
ActiveWorkbook.Close
 
End Sub

(ne pas oubler de déclarer la variable booléenne "Quitter" en début de module)

2 - Dans un module

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
Private Const MF_BYPOSITION As Long = &H400
Private Const mlNUM_SYS_MENU_ITEMS As Long = 9
Private Declare Function GetSystemMenu Lib "user32" _
(ByVal hWnd As Long, ByVal bRevert As Long) As Long
Private Declare Function DeleteMenu Lib "user32" _
(ByVal hMenu As Long, ByVal nPosition As Long, _
ByVal wFlags As Long) As Long
Private Declare Function FindWindowA Lib "user32" _
(ByVal lpClassName As String, ByVal lpWindowName _
As String) As Long
 
Public Sub DisableSystemMenu()
 Dim lHandle As Long, lCount As Long
 
 On Error Resume Next
 lHandle = FindWindowA(vbNullString, Application.Caption)
 If lHandle <> 0 Then
  'désactive la croix de fermeture d'Excel
  'et la commande Fermeture du menu système
  DeleteMenu GetSystemMenu(lHandle, False), 6, &H400
  'supprime le trait de séparation du menu système avant Fermeture
  DeleteMenu GetSystemMenu(lHandle, False), 5, &H400
  'supprime la commande Agrandissement du menu système
  'et la commande Agrandir de la fenêtre
  DeleteMenu GetSystemMenu(lHandle, False), 4, &H400
  'supprime la commande Réduction du menu système
  'et désactive la commande Réduire de la fenêtre
  DeleteMenu GetSystemMenu(lHandle, False), 3, &H400
  'désactive la commande Déplacement du menu système
  DeleteMenu GetSystemMenu(lHandle, False), 2, &H400
  'supprime la commande Déplacement du menu système
  'et désactive la commande Dimension
  DeleteMenu GetSystemMenu(lHandle, False), 1, &H400
  'supprime la commande Restauration du menu système
  'et désactive la commande Restaurer de la fenêtre
  DeleteMenu GetSystemMenu(lHandle, False), 0, &H400
 
 End If
 End Sub
 
Public Sub EnableSystemMenu()
 
'rétablit le menu sytème et les commandes de fenêtre (Réduire, Agrandir, Fermer)
 
 Dim lHandle As Long
 On Error Resume Next
 lHandle = FindWindowA(vbNullString, Application.Caption)
 GetSystemMenu lHandle, True
 End Sub

3 - A ton bouton, nommé ici Btn_Bye, tu associes ce code

Code:

1
2
3
4
5
Private Sub Btn_Bye_Click()
 
Application.Run ("Thisworkbook.Fermeture")
 
End Sub

En espérant que ce code te sera utile.

Cordialement.

Marcel

heuh!!!

bonjour

ou alors suprimer le bouton rouge

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
 
Option Explicit
Public Declare Function GAW Lib "user32" Alias "GetActiveWindow" () As Long
Public Declare Function GWL Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SWL Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_STYLE As Long = -16
Public whdl, forme As Long
 
Sub plus_de_bouton()
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme And Not &H80000
 
End Sub

au plaisir

08/11/2010, 14h16
NEC14

Bonjour patrick,

Ton dernier code "supprimer bouton rouge" tu le mets à l'ouverture du fichier dans ThisWorkBook ?
Merci pour ton aide
08/11/2010, 14h22
patricktoulon

re
bonjour nec

tout dabors le code se trouve dans un module standard

ensuite dans le module "thisworbook"
Code:

1 2 3 4 5 Private Sub Workbook_Open() plus_de_bouton End Sub
au plaisir
08/11/2010, 14h48
NEC14

Merci beaucoup Patrick, c'est super c'est exactement ce que je voulais.
Super cool !
Amicalement
René :P :ccool:

Juste une petite précision, si j'avais voulu garder le trait pour réduire l'écran du fichier que faut-il que j'enlève dans ton code ?

Encore merci

re
sous cette forme c'est assez dificile neammoins je te donne certaines petite chose

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
 
Sub plus_de_bouton()
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme And Not &H80000
 
End Sub
 
Sub rien_que_agrandir() 'avec le bouton fermer
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme Or &H10000
 
End Sub
 
Sub rien_que_reduire_dans_labarre() 'avec le bouton fermer
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme Or &H20000
       End Sub
 
Sub rien_que_les trois boutons() 'avec le bouton fermer
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme Or &H30000
       End Sub
 
 
 
Sub rien_que_l_elasticité() 'avec le bouton fermer
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme Or &H40000
       End Sub
 
 Sub la_totale() 'avec le bouton fermer
  whdl = GAW 'Acquisition du Handle de la fenetre
 
    forme = GWL(whdl, GWL_STYLE) 'Acquisition propriétés
       SWL whdl, GWL_STYLE, forme Or &H70000
       End Sub

je bosse sur une autre version en passant par un autre chemein pour bloquer le bouton rouge tout en ayant le bouton reduire si j 'ai bien compris

au plaisir

08/11/2010, 15h56
NEC14

Oui c'est bien cela, je souhaite garder uniquement le bouton réduire.

Je viens de tester les codes proposés, mais dans tous les cas de figures ou je n'ai rien ou j'ai les 3 symboles.

J'ai encore dû faire quelque chose qu'il ne faut pas ou bien je n'ai rien compris.
Merci pour ton aide

re

bon ben voila servi sur un plataux

dans cet exemple je suprime tout les boutons pour ne remetre que le bouton fermer et reduire et ensuite boquer la fonction du bouton fermer

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
 
Option Explicit
Public Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Public Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public Declare Function FindWindowA Lib "user32" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function GWL Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
Public Declare Function SWL Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Const GWL_STYLE As Long = -16
Public forme As Long
Public Const SC_CLOSE = &HF060&
Public Const MF_BYCOMMAND = &H0&
Public hSysMenu As Long
Public lehandle As Long
 Sub depart()
 'on identifie le handle de la fenetre
 lehandle = FindWindowA(vbNullString, Application.Caption)
 forme = GWL(lehandle, GWL_STYLE) 'Acquisition propriétés
 'on applique le style a la fenetre
 SWL lehandle, GWL_STYLE, forme And Not &H70000 Or &H20000
 'on bloque le bouton stop
 hSysMenu = GetSystemMenu(lehandle, False)
 RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
End Sub
Sub fin()
lehandle = FindWindowA(vbNullString, Application.Caption)
forme = GWL(lehandle, GWL_STYLE) 'Acquisition propriétés
SWL lehandle, GWL_STYLE, forme Or &H70000
hSysMenu = GetSystemMenu(lehandle, True)
RemoveMenu hSysMenu, SC_CLOSE, MF_BYCOMMAND
End Sub

'dans le module thisworkbook

Code:

1
2
3
4
5
6
7
 
 Private Sub Workbook_BeforeClose(Cancel As Boolean)
fin
End Sub
Private Sub Workbook_Open()
depart
End Sub

au plaisir

09/11/2010, 15h11
NEC14

Bonjour Patrick,

Je te prie de m'excuser d'avoir tardé à te répondre mais ce matin j'ai eu un gros soucis avec mon application. Comme tu pourras le constater, j'ai déposé un post ce matin concernant un soucis de DLL. De ce fait, je ne pouvais plus ouvrir mon fichier.
Il m'a fallut tout recommencer le travail réalisé hier.

Sinon au sujet de ton code, quoi dire sinon chapeau bas. Je suis très admiratif devant autant de maîtrise de l'outil vba. Ton code marche à souhait.

Quoi faire pour te remercier ?

A bientôt et mille mercis
Amicalement
René
09/11/2010, 18h40
patricktoulon

re

bonjour nec

pour me remercier tu n'a qu'a cliquer resolu pour que ca serve a d'autres
et voter pourquoi pas
enfin j'espere que ca te sera utile

au plaisr de te rendre service