Soyez le premier à donner votre avis sur cette source.
Vue 12 270 fois - Téléchargée 1 005 fois
Dans le code du ThisWorkBook: 'Macro Créée par : BigFish (Philippe E) 'le :06-11-2008 'Mis à jour le : 03/09/2010 'V1.3 ' Option Explicit Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean) Cancel = True HideSheets WBkSave (SaveAsUI) End Sub Private Sub Workbook_Open() Dim CmdBs As CommandBar 'si les macros on ete activées les feuilles cachées seront affichées 'dans le cas contraire elle resteront cachées et un message d'erreur apparaitra. 'j'ai laissé cette option qui fonctionne si ce fichier n'est pas enregistré avec 'l'option IsAddin a vrai. Dans le cas contraire cela ne sert a rien Application.Run ("Opening") 'desactive la barre "Boîte à outils Contrôles" For Each CmdBs In Application.CommandBars Select Case CmdBs.Name Case "Control Toolbox", "Boîte à outils Contrôles" 'cas Anglais ou Français CmdBs.Enabled = False End Select Next 'initialisation de la classe Set XlAppli.XL = Excel.Application Call XlAppli.InitClass 'on interdit l'utilisation des racourcis Alt+F11 et Alt+F8 Application.OnKey "%{F11}", "MessageDeLimitation" Application.OnKey "%{F8}", "MessageDeLimitation" DoEvents 'ce fichier a été sauvé avec l'option IsAddin a vrai donc on le passe a false 'pour lui redonner toutes ses fonctions de Workbook classic If ThisWorkbook.IsAddin = True Then ThisWorkbook.IsAddin = False 'si le VBE est ouvert on le ferme mais pour que cela fonctionne l'option 'de securite "Faire confiance au projet Visual Basic" doit etre cochée. On Error Resume Next If Application.VBE.MainWindow.Visible = True Then Application.VBE.MainWindow.Visible = False MyFileIsOpen = True End Sub Private Sub Workbook_BeforeClose(Cancel As Boolean) 'une partie de ce qui suit ne sert qu'a gerer le passage IsAddin = True de ce fichier si 'l'utilisateur veut sauver avant de fermer 'Pour cela on vas substituer au message d'excel notre propre message ce qui 'permet de gerer le cas du bouton cancel If MyFileIsOpen = True Then Exit Sub Dim Reponse As VbMsgBoxResult If ThisWorkbook.Saved = True Then 'retour a la normale Defaut 'on vide la classe Call XlAppli.EmptyClass Else Cancel = True 'ici notre message perso: On Error Resume Next Reponse = MsgBox("Voulez-vous sauver les modifications effectuées dans '" & ActiveWorkbook.Name & "' ? ", vbExclamation + vbYesNoCancel) Select Case Reponse Case vbYes 'l'utilisateur veut sauver avant de fermer le fichier HideSheets Application.EnableEvents = False 'pour eviter de passer par l'evenement Workbook_BeforeSave ThisWorkbook.IsAddin = True ThisWorkbook.Save ThisWorkbook.Saved = True Application.EnableEvents = True Application.DisplayAlerts = True Application.ScreenUpdating = True Cancel = False Case vbNo 'l'utilisateur ne veut pas sauver. Pour cela: 'retour a la normale Defaut 'on vide la classe Call XlAppli.EmptyClass 'on laisse croire excel que le fichier a été sauvé ThisWorkbook.Saved = True 'on autorise la fermeture Cancel = False End Select ' si cancel rien ne ce passe End If End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- Dans le module nomé module1 'Macro Créée par : BigFish (Philippe E) 'le :15-11-2008 'Mis à jour le : 03/09/2010 'V1.4 ' Option Explicit Public XlAppli As New ClasseAppli, MyFileIsOpen As Boolean Sub Defaut() Dim CmdBtn As office.CommandBarButton, CmdBs As CommandBar 'Retablit l'utilisation des raccourcis Alt+F11 et Alt+F8 Application.OnKey "%{F11}" Application.OnKey "%{F8}" 'Active la barre "Boîte à outils Contrôles" For Each CmdBs In Application.CommandBars Select Case CmdBs.Name Case "Control Toolbox", "Boîte à outils Contrôles" CmdBs.Enabled = True End Select Next End Sub Sub viderclass() Call XlAppli.EmptyClass End Sub Sub HideSheets() 'Cache toute les feuilles a l'exception de la feuille starting notice 'j'ai laissé cette option qui fonctionne si ce fichier n'est pas enregistré avec 'l'option IsAddin a vrai. Dans le cas contraire cela ne sert a rien Dim MySheet As Worksheet Application.ScreenUpdating = False Application.DisplayAlerts = False If Sheets("starting notice").Visible = xlVeryHidden Then Sheets("starting notice").Visible = True For Each MySheet In ThisWorkbook.Worksheets If Not MySheet.Name = "starting notice" Then MySheet.Visible = xlVeryHidden End If Next End Sub Sub Opening() Dim MySheet As Worksheet 'Affiche toute les feuilles a l'exception de la feuille starting notice Application.ScreenUpdating = False Application.DisplayAlerts = False ThisWorkbook.IsAddin = False For Each MySheet In ThisWorkbook.Worksheets If Not MySheet.Name = "starting notice" Then MySheet.Visible = True End If Next If Sheets("starting notice").Visible = True Then Sheets("starting notice").Visible = xlVeryHidden Application.ScreenUpdating = True Application.DisplayAlerts = True Application.EnableEvents = True ThisWorkbook.Saved = True End Sub Sub WBkSave(ByVal SaveAsUI As Boolean) 'ici on prend en charge les sauvegardes pour pouvoir gerer l'option IsAddin Dim FileSaveName As String, Reponse As VbMsgBoxResult Application.DisplayAlerts = False Application.EnableEvents = False If SaveAsUI = False Then 'sauvegarde direct ThisWorkbook.IsAddin = True ThisWorkbook.Save Else 'sauver sous FileSaveName = Application.GetSaveAsFilename(ThisWorkbook.Name) If Not FileSaveName = "False" Then 'si l'utilisateur n'a pas utilisé le bouton Cancel If Not Dir(FileSaveName) = "" Then 'si le fichier existe deja Reponse = MsgBox("le fichier '" & Dir(FileSaveName) & "' existe déjà. voulez-vous remplacer le fichier existant ? ", vbExclamation + vbYesNo) If Reponse = vbYes Then ThisWorkbook.IsAddin = True ThisWorkbook.SaveAs Filename:=FileSaveName, AddToMru:=True End If Else 'si le fichier n'existe pas ThisWorkbook.IsAddin = True ThisWorkbook.SaveAs Filename:=FileSaveName, AddToMru:=True End If End If End If Application.EnableEvents = True DoEvents 'on donne les moyens a excel de faire la sauvegarde avant de passer a la suite Opening End Sub Sub MessageDeLimitation() MsgBox "Vos droits sur ce fichier ne vous permettent pas d'acceder à ces fonctions !", vbExclamation End Sub Sub ClosingThisFile() MyFileIsOpen = False ThisWorkbook.Close End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- Dans le module de classe nomé ClasseAppli 'Macro Créée par : BigFish (Philippe E) 'Macro Créée par : BigFish (Philippe E) 'le :15-11-2008 'Mis à jour le : 03/09/2010 'V1.2 ' Option Explicit Public WithEvents XL As Excel.Application Dim ClassCmdBrBtn() As ClasseCommandeBarBouton, NbButton As Integer 'Permet de vider la classe Public Sub EmptyClass() Dim i As Integer For i = 1 To NbButton On Error Resume Next Set ClassCmdBrBtn(i).BoutonBarre = Nothing Next End Sub 'Remplissage de la classe Public Sub InitClass() Dim i As Integer, MyCmdBar As CommandBar NbButton = Application.CommandBars("Visual Basic").Controls.Count 'on determine le nombre de bouton et on dimensionne la variable tableau ReDim Preserve ClassCmdBrBtn(NbButton) 'on Ajoute a la classe chaque bouton de la barre Visual Basic For i = 1 To NbButton Set ClassCmdBrBtn(i) = New ClasseCommandeBarBouton Set ClassCmdBrBtn(i).BoutonBarre = Application.CommandBars("Visual Basic").Controls(i) Next End Sub Private Sub XL_WorkbookBeforeClose(ByVal Wb As Workbook, Cancel As Boolean) 'interdit la fermeture de ce classeur ou d'excel tant qu'il est ouvert If Wb.Name = ThisWorkbook.Name And MyFileIsOpen = True Then Cancel = True End If End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- Dans le module de classe nomé ClasseCommandeBarBouton 'Macro Créée par : BigFish (Philippe E) 'le :05-11-2008 'V1.1 ' Option Explicit Public WithEvents BoutonBarre As office.CommandBarButton Private Sub BoutonBarre_Click(ByVal Ctrl As office.CommandBarButton, CancelDefault As Boolean) Select Case Ctrl.Caption 'Version Anglaise jusqu'a Xl2003 Case "&Design Mode", "&Visual Basic Editor", "Control T&oolbox", "&Record New Macro...", "&Macros..." CancelDefault = True Action 'Version Française jusqu'a Xl2003 Case "Nouv&elle macro...", "&Visual Basic Editor", "&Boîte à outils Contrôles", "Mode &Création" CancelDefault = True Action 'Version Française A partir de Xl2007 Case "Mo&de Création" CancelDefault = True Action End Select End Sub Sub Action() MsgBox "Vos droits sur ce fichier ne vous permettent pas d'acceder à ces fonctions !", vbExclamation End Sub ----------------------------------------------------------------------------------------- ----------------------------------------------------------------------------------------- Dans le code de la feuille "Sheet1" 'Macro Créée par : BigFish (Philippe E) 'le 03/09/2010 'V1.0 ' 'Bouton [Fermer ce fichier] de la feuille "Sheet1" Private Sub CommandButton1_Click() ClosingThisFile End Sub
11 févr. 2011 à 17:00
10 févr. 2011 à 09:03
18 nov. 2008 à 15:22
merci Le pivert pour la note et la remarque sur la MsgBox. Je viens de la supprimer.
A+
18 nov. 2008 à 10:11
Trés bon programme.Sur la dernière version j'ai un MsgBox "Faux" à l'ouverture qu'il n'y avait pas sur la précédente version.Pour ce qui est de la "Boîte à outils Contrôles" cela fonctionne en français.
14 nov. 2008 à 19:55
il me reste une incertitude sur le nom Français de la barre "Boîte à outils Contrôles".
Si la barre apparait c'est que le nom n'est pas bon donc merci de me le signaler et si possible de me donner le vrai nom ainsi que la version excel d'ou est issu ce nom.
3ddI7IHd
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.