je crée une barre d'outils avec auto-open
Si je relance cette macro une seconde fois, les images des boutons sont de
très moins bonne qualité...
quelqu'un pourrait-il trouver l'erreur dans le code ci-joint
Un grand merci d'avance
Voici le code
________________________________
Dim Mybar As CommandBar
On Error GoTo ErrorHandler 'en fin de macro si la barre existe déjà
Set Mybar = CommandBars.Add(Name:="Comptabilité", _
Position:=msoBarTop, Temporary:=True)
On Error GoTo 0
With Mybar
.Visible = True (au début ou la fin ça ne change rien)
.Controls.Add(Type:=msoControlButton, ID:=1, before:=1).Caption =
"Réimporter une sauvegarde" '"Ajouter, modifier un compte Recettes ou
Dépenses"
.Controls(1).OnAction = "Recupsauvegarde"
Sheets("images").Shapes("image 1").Copy
.Controls(1).PasteFace
.Controls.Add(Type:=msoControlButton, ID:=1, before:=2).Caption =
"Paramètres paroisse et Mot de Passe"
.Controls(2).OnAction = "Dossier"
Sheets("images").Shapes("image 2").Copy
.Controls(2).PasteFace
etc....
.Controls.Add(Type:=msoControlDropdown, ID:=1, before:=11).Caption = "Détail
du compte d'UN cotisan"
.Controls(11).OnAction = "Uncotisant"
.Controls(11).Tag = "Cotisant"
.Controls(11).DropDownWidth = -1
.Controls(11).Width = 75
'charger les noms de paroissiens
On Error GoTo FauxNom
Workbooks("ERF.xls").Activate
On Error GoTo 0
GoTo Suite
FauxNom:
Workbooks("images.xls").Close (False)
MsgBox "Vous lancez un fichier dont le nom n'est pas ""ERF.xls"" :
Renommez-le avant de le lancer", vbCritical
On Error GoTo 0
End
Suite:
Worksheets("Paroissiens").Activate
On Error GoTo Reprise1
Range("A1").End(xlDown).Select
DernièreLigne = ActiveCell.Row
Dim Ajout As String
For i = 2 To DernièreLigne
Ajout = Worksheets("Paroissiens").Range("A" & i).Value
Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("C" & i).Value
Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("D" & i).Value
Ajout = Ajout & Space(4) & Format(Worksheets("Paroissiens").Range("H" &
i).Value, "0# ## ## ## ##")
.Controls(11).AddItem Ajout, i - 1
Next
Reprise1:
On Error GoTo 0
etc....
etc
End With
Set Mybar = Nothing
ErrorHandler: ' Routine de gestion d'erreur si barre outils présente.
' Évalue le numéro d'erreur.
Select Case Err.Number
Case 5
Application.DisplayAlerts = False
Application.CommandBars("Comptabilité").Delete
Application.DisplayAlerts = True
Case Else
' Traite les autres situations ici...
MsgBox "erreur N°" & Err.Description, vbCritical
End Select
Resume ' Reprend l'exécution au niveau de la ligne à l'origine de
l'erreur
Cette action est irreversible, confirmez la suppression du commentaire ?
Signaler le commentaire
Veuillez sélectionner un problème
Nudité
Violence
Harcèlement
Fraude
Vente illégale
Discours haineux
Terrorisme
Autre
michdenis
Bonjour André,
Je n'ai pas testé ton code, mais c'est une bonne idée de commencer par détruire la barre d'outils que tu veux créer en premier au cas où elle existerait déjà. Si elle n'existe pas, cette ligne de code provoque une erreur.
Ta procédure pourrait débuter par :
Application.CommandBars("Comptabilité").Delete
Salutations!
"AndréSch" a écrit dans le message de news: Bonjour à tous
je crée une barre d'outils avec auto-open Si je relance cette macro une seconde fois, les images des boutons sont de très moins bonne qualité...
quelqu'un pourrait-il trouver l'erreur dans le code ci-joint
Un grand merci d'avance
Voici le code ________________________________ Dim Mybar As CommandBar
On Error GoTo ErrorHandler 'en fin de macro si la barre existe déjà Set Mybar = CommandBars.Add(Name:="Comptabilité", _ Position:=msoBarTop, Temporary:=True) On Error GoTo 0
With Mybar
.Visible = True (au début ou la fin ça ne change rien)
.Controls.Add(Type:=msoControlButton, ID:=1, before:=1).Caption "Réimporter une sauvegarde" '"Ajouter, modifier un compte Recettes ou Dépenses" .Controls(1).OnAction = "Recupsauvegarde" Sheets("images").Shapes("image 1").Copy .Controls(1).PasteFace
.Controls.Add(Type:=msoControlButton, ID:=1, before:=2).Caption "Paramètres paroisse et Mot de Passe" .Controls(2).OnAction = "Dossier" Sheets("images").Shapes("image 2").Copy .Controls(2).PasteFace
etc....
.Controls.Add(Type:=msoControlDropdown, ID:=1, before:).Caption = "Détail du compte d'UN cotisan" .Controls(11).OnAction = "Uncotisant" .Controls(11).Tag = "Cotisant" .Controls(11).DropDownWidth = -1 .Controls(11).Width = 75
'charger les noms de paroissiens On Error GoTo FauxNom Workbooks("ERF.xls").Activate On Error GoTo 0 GoTo Suite FauxNom: Workbooks("images.xls").Close (False) MsgBox "Vous lancez un fichier dont le nom n'est pas ""ERF.xls"" : Renommez-le avant de le lancer", vbCritical On Error GoTo 0 End Suite:
Worksheets("Paroissiens").Activate On Error GoTo Reprise1 Range("A1").End(xlDown).Select DernièreLigne = ActiveCell.Row Dim Ajout As String For i = 2 To DernièreLigne Ajout = Worksheets("Paroissiens").Range("A" & i).Value Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("C" & i).Value Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("D" & i).Value Ajout = Ajout & Space(4) & Format(Worksheets("Paroissiens").Range("H" & i).Value, "0# ## ## ## ##") .Controls(11).AddItem Ajout, i - 1 Next
Reprise1: On Error GoTo 0 etc....
etc
End With
Set Mybar = Nothing
ErrorHandler: ' Routine de gestion d'erreur si barre outils présente. ' Évalue le numéro d'erreur.
Select Case Err.Number Case 5 Application.DisplayAlerts = False Application.CommandBars("Comptabilité").Delete Application.DisplayAlerts = True Case Else ' Traite les autres situations ici... MsgBox "erreur N°" & Err.Description, vbCritical
End Select Resume ' Reprend l'exécution au niveau de la ligne à l'origine de l'erreur
Bonjour André,
Je n'ai pas testé ton code, mais c'est une bonne idée de commencer
par détruire la barre d'outils que tu veux créer en premier au cas où
elle existerait déjà. Si elle n'existe pas, cette ligne de code provoque
une erreur.
Ta procédure pourrait débuter par :
Application.CommandBars("Comptabilité").Delete
Salutations!
"AndréSch" <cephaspierre@aol.com> a écrit dans le message de news: ezwOcLKAGHA.208@tk2msftngp13.phx.gbl...
Bonjour à tous
je crée une barre d'outils avec auto-open
Si je relance cette macro une seconde fois, les images des boutons sont de
très moins bonne qualité...
quelqu'un pourrait-il trouver l'erreur dans le code ci-joint
Un grand merci d'avance
Voici le code
________________________________
Dim Mybar As CommandBar
On Error GoTo ErrorHandler 'en fin de macro si la barre existe déjà
Set Mybar = CommandBars.Add(Name:="Comptabilité", _
Position:=msoBarTop, Temporary:=True)
On Error GoTo 0
With Mybar
.Visible = True (au début ou la fin ça ne change rien)
.Controls.Add(Type:=msoControlButton, ID:=1, before:=1).Caption "Réimporter une sauvegarde" '"Ajouter, modifier un compte Recettes ou
Dépenses"
.Controls(1).OnAction = "Recupsauvegarde"
Sheets("images").Shapes("image 1").Copy
.Controls(1).PasteFace
.Controls.Add(Type:=msoControlButton, ID:=1, before:=2).Caption "Paramètres paroisse et Mot de Passe"
.Controls(2).OnAction = "Dossier"
Sheets("images").Shapes("image 2").Copy
.Controls(2).PasteFace
etc....
.Controls.Add(Type:=msoControlDropdown, ID:=1, before:).Caption = "Détail
du compte d'UN cotisan"
.Controls(11).OnAction = "Uncotisant"
.Controls(11).Tag = "Cotisant"
.Controls(11).DropDownWidth = -1
.Controls(11).Width = 75
'charger les noms de paroissiens
On Error GoTo FauxNom
Workbooks("ERF.xls").Activate
On Error GoTo 0
GoTo Suite
FauxNom:
Workbooks("images.xls").Close (False)
MsgBox "Vous lancez un fichier dont le nom n'est pas ""ERF.xls"" :
Renommez-le avant de le lancer", vbCritical
On Error GoTo 0
End
Suite:
Worksheets("Paroissiens").Activate
On Error GoTo Reprise1
Range("A1").End(xlDown).Select
DernièreLigne = ActiveCell.Row
Dim Ajout As String
For i = 2 To DernièreLigne
Ajout = Worksheets("Paroissiens").Range("A" & i).Value
Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("C" & i).Value
Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("D" & i).Value
Ajout = Ajout & Space(4) & Format(Worksheets("Paroissiens").Range("H" &
i).Value, "0# ## ## ## ##")
.Controls(11).AddItem Ajout, i - 1
Next
Reprise1:
On Error GoTo 0
etc....
etc
End With
Set Mybar = Nothing
ErrorHandler: ' Routine de gestion d'erreur si barre outils présente.
' Évalue le numéro d'erreur.
Select Case Err.Number
Case 5
Application.DisplayAlerts = False
Application.CommandBars("Comptabilité").Delete
Application.DisplayAlerts = True
Case Else
' Traite les autres situations ici...
MsgBox "erreur N°" & Err.Description, vbCritical
End Select
Resume ' Reprend l'exécution au niveau de la ligne à l'origine de
l'erreur
Je n'ai pas testé ton code, mais c'est une bonne idée de commencer par détruire la barre d'outils que tu veux créer en premier au cas où elle existerait déjà. Si elle n'existe pas, cette ligne de code provoque une erreur.
Ta procédure pourrait débuter par :
Application.CommandBars("Comptabilité").Delete
Salutations!
"AndréSch" a écrit dans le message de news: Bonjour à tous
je crée une barre d'outils avec auto-open Si je relance cette macro une seconde fois, les images des boutons sont de très moins bonne qualité...
quelqu'un pourrait-il trouver l'erreur dans le code ci-joint
Un grand merci d'avance
Voici le code ________________________________ Dim Mybar As CommandBar
On Error GoTo ErrorHandler 'en fin de macro si la barre existe déjà Set Mybar = CommandBars.Add(Name:="Comptabilité", _ Position:=msoBarTop, Temporary:=True) On Error GoTo 0
With Mybar
.Visible = True (au début ou la fin ça ne change rien)
.Controls.Add(Type:=msoControlButton, ID:=1, before:=1).Caption "Réimporter une sauvegarde" '"Ajouter, modifier un compte Recettes ou Dépenses" .Controls(1).OnAction = "Recupsauvegarde" Sheets("images").Shapes("image 1").Copy .Controls(1).PasteFace
.Controls.Add(Type:=msoControlButton, ID:=1, before:=2).Caption "Paramètres paroisse et Mot de Passe" .Controls(2).OnAction = "Dossier" Sheets("images").Shapes("image 2").Copy .Controls(2).PasteFace
etc....
.Controls.Add(Type:=msoControlDropdown, ID:=1, before:).Caption = "Détail du compte d'UN cotisan" .Controls(11).OnAction = "Uncotisant" .Controls(11).Tag = "Cotisant" .Controls(11).DropDownWidth = -1 .Controls(11).Width = 75
'charger les noms de paroissiens On Error GoTo FauxNom Workbooks("ERF.xls").Activate On Error GoTo 0 GoTo Suite FauxNom: Workbooks("images.xls").Close (False) MsgBox "Vous lancez un fichier dont le nom n'est pas ""ERF.xls"" : Renommez-le avant de le lancer", vbCritical On Error GoTo 0 End Suite:
Worksheets("Paroissiens").Activate On Error GoTo Reprise1 Range("A1").End(xlDown).Select DernièreLigne = ActiveCell.Row Dim Ajout As String For i = 2 To DernièreLigne Ajout = Worksheets("Paroissiens").Range("A" & i).Value Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("C" & i).Value Ajout = Ajout & Space(4) & Worksheets("Paroissiens").Range("D" & i).Value Ajout = Ajout & Space(4) & Format(Worksheets("Paroissiens").Range("H" & i).Value, "0# ## ## ## ##") .Controls(11).AddItem Ajout, i - 1 Next
Reprise1: On Error GoTo 0 etc....
etc
End With
Set Mybar = Nothing
ErrorHandler: ' Routine de gestion d'erreur si barre outils présente. ' Évalue le numéro d'erreur.
Select Case Err.Number Case 5 Application.DisplayAlerts = False Application.CommandBars("Comptabilité").Delete Application.DisplayAlerts = True Case Else ' Traite les autres situations ici... MsgBox "erreur N°" & Err.Description, vbCritical
End Select Resume ' Reprend l'exécution au niveau de la ligne à l'origine de l'erreur
