Création d'un objet shape double traits.
Bonjour,
Sauf erreur de ma part, je n'ai pas vu la possibilité de créer un double trait comme dans les bordures par exemple. Dans votre cas, une solution simpliste serait de créer un rectangle.
Sinon, ci-dessous, le genre de code que j'utilise pour créer mes objets. Le principe est de créer deux traits espacés d'une distance à votre convenance et une fois groupés ils pourront prendre les différentes propriétés souhaitées y compris l'angle de rotation.
Le soucis pour réaliser un groupement, c'est qu'il ne faut pas de nom en double. La fonction jointe permet de connaître l'indice du dernier objet de même type existant sur la feuille et d'incrémenter de 1 cet indice.
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
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 |
Cordialement.
Création d'un objet shape double traits.
Bonjour,
Merci pour cette proposition. Elle serait super si mes traits n'étaient que droit.
Le problème c'est que le double trait symbolise un fourreau autour d'un cable électrique donc tracé rarement rectiligne.
Le cadre votre proposition pour le moment mais je cherche encore.
Cordialement
