Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
If Intersect(Target, [A6:N9]) Is Nothing Then Exit Sub 'plage à adapter
Dim zone As Range, lig, x#, y#, s As Shape
Cancel = True
Set zone = [J14:N38] 'zone des Shapes, à adapter
lig = Target.Row - 3
Application.ScreenUpdating = False
'---RAZ---
For Each s In Shapes
If Not Intersect(s.TopLeftCell, zone) Is Nothing _
And s.Name <> "Rectangle 1" Then s.Delete
Next
'---initialisation---
With Shapes("Rectangle 1")
.Left = zone(1).Left + 0.1
.Top = zone(1).Top + 0.1
.Width = zone.Width - 0.2
.Visible = False
End With
x = zone(1).Left + 16
y = zone(1).Top + 16
'---Copies des Shapes à adapter---
CopieShape [K4:M4], lig, Shapes("Picture 66"), x, y, "Réhausse", [R7], 0
CopieShape [J4], lig, Shapes("Picture 63"), x, y, "Dalle", [R9], 0
CopieShape [E4:I4], lig, Shapes("Picture 67"), x, y, "TR", [R13], 0
CopieShape [B4:D4], lig, Shapes("Picture 64"), x, y, "ED", [R18], 0
If y > zone(1).Top + 16 Then
CopieShape [A4], lig, Shapes("Picture 65"), x, y, "FDR ht", [R24], 1
Shapes("Rectangle 1").Visible = True
'---ajustement de la hauteur du groupe à la zone des Shapes---
For Each s In Shapes
If Not Intersect(s.TopLeftCell, zone) Is Nothing Then s.Select False
Next
With Selection.ShapeRange.Group 'groupage
.Height = zone.Height - 0.2
.Ungroup
End With
ActiveCell.Activate
End If
Application.ScreenUpdating = True
End Sub
Sub CopieShape(r As Range, lig, s As Shape, x#, y#, titre$, href#, der As Byte)
Dim i, coef#, h#, w#
For Each r In r
For i = 1 To IIf(der, 1, Val(r(lig)))
s.Copy
Me.Paste
With Selection
.Left = x
.Top = y
.ShapeRange.LockAspectRatio = msoFalse
coef = 100 * IIf(der, r(lig), r(2)) / href 'r(2) => ligne masquée
.ShapeRange.ScaleHeight coef, msoFalse, msoScaleFromTopLeft
h = .Height
w = .Width
End With
y = y + h
Me.DrawingObjects("ZoneTexte 1").Copy
Me.Paste
Selection.Text = titre & " " & _
IIf(der, 100 * Val(Replace(r(lig), ",", ".")), r)
Selection.Left = x + w
Selection.Top = y - h / 2 - Selection.Height / 2
With Me.Shapes("Rectangle 1")
.Height = y + 16 - .Top
End With
Next
Next
End Sub
