Logo GNT
Actualités Tests & Guides Bons Plans
GTA 6 iPhone 17 Copilot Switch 2 Temu ChatGPT Tesla
OVH Cloud OVH Cloud
Entraide Applications Microsoft Office Excel Pb Objets imprimables

Pb Objets imprimables

2 réponses
Avatar
bsh
Bonjour à toutes et à tous

J'ai un petit souci avec la macro ci dessous, récupéré ur le site de G.
Mourmant : Le pb est que les 2 rectangles en rouge sont imprimables,
pourtant ".PrintObject = False"
Quelqu'un a t il une idée pour les rendre NON imprimables.

Merci pour votre aide
BS


Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' Macro créée par G.Mourmant le 01/09/2001
' Site web : www.polykromy.com
' Copyright Gaetan Mourmant
'*** Définition des variables ***
h = ActiveCell.Height
w2 = ActiveCell.Width
t = ActiveCell.Top
w = ActiveCell.Left

'Teste si les rectangles existent déjà.
On Error Resume Next
ActiveSheet.Shapes("RectangleV").Delete
On Error Resume Next
ActiveSheet.Shapes("RectangleH").Delete

'Ajoute les rectangles
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, t, w, h).Name =
"RectangleV"
With ActiveSheet.Shapes("RectangleV")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.PrintObject = False
End With
ActiveSheet.Shapes.AddShape(msoShapeRectangle, w, 0, w2, t).Name =
"RectangleH"
With ActiveSheet.Shapes("RectangleH")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.PrintObject = False
End With
End Sub
Signaler un problème avec ce contenu

2 réponses

Supprimer
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
Avatar
Modeste
Bonjour,
sans trop avoir compris la raison .....
ci-dessous les corrections :
!!!!!modifications!!!!!!

Private Sub Worksheet_SelectionChange(ByVal Target As
Excel.Range)
' Macro créée par G.Mourmant le 01/09/2001
' Site web : www.polykromy.com
' Copyright Gaetan Mourmant
'*** Définition des variables ***
h = ActiveCell.Height
w2 = ActiveCell.Width
t = ActiveCell.Top
w = ActiveCell.Left
'Teste si les rectangles existent déjà.
On Error Resume Next
ActiveSheet.Shapes("RectangleV").Delete
On Error Resume Next
ActiveSheet.Shapes("RectangleH").Delete
'Ajoute les rectangles
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, t, w,
h).Name = "RectangleV"
With ActiveSheet.Shapes("RectangleV")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
'!!!!!!!!modification!!!!!!!!!!!
.Select
With Selection
.PrintObject = False
End With
End With
'------------------
ActiveSheet.Shapes.AddShape(msoShapeRectangle, w, 0,
w2, t).Name = "RectangleH"
With ActiveSheet.Shapes("RectangleH")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
'!!!!!!!!modification!!!!!!!!!!!!!!!!!!!!!!!!
.Select
With Selection
.PrintObject = False
End With
End With
'!!!!!!!modification!!!!!!!!!!!!
Target.Select
End Sub
Avatar
Alain CROS
Bonjour

PrintObject n'est pas une propriété d'un object shape.
Le On Error Resume Next te masque cette erreur.
Cette instruction n'est a utiliser que là ou elle est strictement nécessaire.
Dés qu'elle n'est plus utile --> On Error Goto 0.

Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
Dim h&, w2&, t&, w&, Shp As Shape
With ActiveCell
h = .Height
w2 = .Width
t = .Top
w = .Left
End With
With ActiveSheet
'Teste si les rectangles existent déjà.
On Error Resume Next
.Shapes("RectangleV").Delete
.Shapes("RectangleH").Delete
On Error GoTo 0
'Ajoute les rectangles
Set Shp = .Shapes.AddShape(msoShapeRectangle, 0, t, w, h)
With Shp
.Name = "RectangleV"
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.ControlFormat.PrintObject = False
End With
Set Shp = .Shapes.AddShape(msoShapeRectangle, w, 0, w2, t)
With Shp
.Name = "RectangleH"
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.ControlFormat.PrintObject = False
End With
End With
Set Shp = Nothing
End Sub

Alain CROS

"bsh" a écrit dans le message de news:
Bonjour à toutes et à tous

J'ai un petit souci avec la macro ci dessous, récupéré ur le site de G.
Mourmant : Le pb est que les 2 rectangles en rouge sont imprimables,
pourtant ".PrintObject = False"
Quelqu'un a t il une idée pour les rendre NON imprimables.

Merci pour votre aide
BS


Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
' Macro créée par G.Mourmant le 01/09/2001
' Site web : www.polykromy.com
' Copyright Gaetan Mourmant
'*** Définition des variables ***
h = ActiveCell.Height
w2 = ActiveCell.Width
t = ActiveCell.Top
w = ActiveCell.Left

'Teste si les rectangles existent déjà.
On Error Resume Next
ActiveSheet.Shapes("RectangleV").Delete
On Error Resume Next
ActiveSheet.Shapes("RectangleH").Delete

'Ajoute les rectangles
ActiveSheet.Shapes.AddShape(msoShapeRectangle, 0, t, w, h).Name > "RectangleV"
With ActiveSheet.Shapes("RectangleV")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.PrintObject = False
End With
ActiveSheet.Shapes.AddShape(msoShapeRectangle, w, 0, w2, t).Name > "RectangleH"
With ActiveSheet.Shapes("RectangleH")
.Fill.Visible = msoFalse
.Fill.Transparency = 0#
.Line.Weight = 3#
.Line.ForeColor.SchemeColor = 10
.PrintObject = False
End With
End Sub