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 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57
|
Sub TestCreerUnDoubleTrait()
CreerUnDoubleTrait 10, 6, 200, 6, 5, 0, 2
End Sub
Sub CreerUnDoubleTrait(ByVal PosH1 As Single, ByVal PosV1 As Single, ByVal PosH2, ByVal PosV2 As Single, ByVal Espacement As Single, ByVal AngleObjet As Single, ByVal EpaisseurTrait As Single)
Dim Nom1 As Variant
Dim Nom2 As Variant
Dim ObjetRange As ShapeRange
Dim NbTraitsExistants As Long
NbTraitsExistants = NbObjetsExistants("Trait ")
ActiveSheet.Shapes.AddLine(PosH1, PosV1, PosH2, PosV2).Select
Selection.Name = "Trait " & CStr(NbTraitsExistants) & "1"
Nom1 = Selection.Name
ActiveSheet.Shapes.AddLine(PosH1, PosV1 + Espacement, PosH2, PosV2 + Espacement).Select
Selection.Name = "Trait" & CStr(NbTraitsExistants) & "2"
Nom2 = Selection.Name
Set ObjetRange = ActiveSheet.Shapes.Range(Array(Nom1, Nom2))
ObjetRange.Group.Select
With ObjetRange
.Name = "Trait " & CStr(NbTraitsExistants)
.ZOrder msoBringToFront
.Fill.Visible = msoFalse
.Line.ForeColor.RGB = RGB(204, 0, 0)
.Line.Transparency = 0
.Line.Weight = EpaisseurTrait
.Rotation = AngleObjet
End With
Set ObjetRange = Nothing
End Sub
Function NbObjetsExistants(ByVal NomObjet As String) As Long
Dim ItemShape As Shape
NbObjetsExistants = 0
For Each ItemShape In ActiveSheet.Shapes
If Len(ItemShape.Name) >= Len(NomObjet) Then
If Mid(ItemShape.Name, 1, Len(NomObjet)) = NomObjet Then
On Error Resume Next
NbObjetsExistants = CLng(Mid(ItemShape.Name, Len(NomObjet) + 1))
End If
End If
Next ItemShape
NbObjetsExistants = NbObjetsExistants + 1
End Function |
Partager