Macro Creation Bouton d'action

Version imprimable

Bonjour,

J'ai une macro qui génère une page automatiquement avec plein de truc dessus, afin que tout soit automatisé, je gère la Mise en page avec :

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
  With ActiveSheet
        .HPageBreaks.Add .Range("A44")
        End With
 
With activesheet
        .PageSetup.LeftMargin = Application.InchesToPoints(0.17)
        .PageSetup.RightMargin = Application.InchesToPoints(0.17)
        .PageSetup.TopMargin = Application.InchesToPoints(0.17)
        .PageSetup.BottomMargin = Application.InchesToPoints(1)
        .PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
        .PageSetup.FooterMargin = Application.InchesToPoints(0.5)
        .PageSetup.CenterHorizontally = True
        .PageSetup.CenterVertically = True
        .PageSetup.Orientation = xlLandscape
        .PageSetup.Zoom = 80
'Et ensuite print module ........

Ce code qui fonctionne tourne pendant 10 à 22 secondes (suivant les machines) pour s'executer, c'est BEAUCOUP TROP Long !

Donc je voudrais essayer de créer un bouton pour n'activer ce code que lorsqu'on souhaitera imprimer !

Donc pour créer mon bouton j'utilise

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
 ActiveSheet.Buttons.Add(4.5, 0.75, 234, 30.75).Select
 
'Erreur ici : 
    Selection.OnAction = "Sheet1.Print_setup"  'Object Defined or Property error !!!
    ActiveSheet.Shapes("Button 10").Select
    Selection.Characters.Text = "Page Setup & Print"
    With Selection.Characters(Start:=1, Length:=18).Font
        .Name = "Arial"
        .FontStyle = "Regular"
        .Size = 10
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ColorIndex = xlAutomatic
    End With

OU j'ai aussi essayer OLEObject .... Mais bon bref ça marche pas !!

Je pige pas pourquoi ???

bonjour
un exemple

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
 
Sub bouton()
Dim feuille As Worksheet
Dim bcommand As Shape
 
Set grillef = Worksheets("le nom ")
With grillef
    Set bcommand = .Shapes.AddShape(msoShapeRectangle, gauche + 200, haut, 55, 12)
        With bcommand
        .Fill.ForeColor.SchemeColor = 12
        .OnAction = "sortie" 'appelle de la procedure sortie
        .OLEFormat.Object.Text = "QUITTER"
        .AutoShapeType = msoShapeRectangle
        End With
End With
End Sub

02/07/2007, 19h08
patbou
re

dans la ligne de code
Code:

1 2 Set bcommand = .Shapes.AddShape(msoShapeRectangle, gauche + 200, haut, 55, 12)
gauche et haut a modifier par une valeur !!!
03/07/2007, 10h11
nono le golfeur

Merci beaucoup,

Ce code marche très bien sur un feuille X mais le problème c'est que je suis incapable de définir le nom de la feuille puisqu'il change à chaque fois !!

Quand je créer une page, il lui donne le nom "Report" & Valeur dans liste deroulante & valeur liste deroulante 2...

Donc faut que j'essai d'adapter mais je vois pas torp comment !!!

Merci en tout cas !! :king:

J'ai adapté le code pour le mettre directement dans la Macro afin de pouvoir recupérer la variable nom qui correspond au nom de la feuille !!

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
'**************************************************************************
'<<<<<<<<<<<<<<<<<<<<<<<<<END GRAPHS CREATION>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
'<<<<<<<<<<<<<<<<<< CREATION BUTTON PRINT SETTINGS  >>>>>>>>>>>>>>>>>>>>>>>
'**************************************************************************
 
 
Set grillef = Worksheets(nom)
 
With grillef
 
    Set bcommand = .Shapes.AddShape(msoShapeRectangle, 0, 0, 200, 20)
        With bcommand
        .Fill.ForeColor.RGB = RGB(225, 244, 253)
        .OnAction = "Print_setting"
        .OLEFormat.Object.Text = "Page Setup & Print"
        .AutoShapeType = msoShapeRectangle
        .TextFrame.HorizontalAlignment = xlHAlignCenter
        .Line.Weight = 3
        .ControlFormat.PrintObject = False
 
     End With
 
End With
 
 
'Exit Macro !

Merci Beaucoup à tous...

Arnaud