Créer un trait double

**ced25870** · 02/02/2014, 19h53

Bonjour,

Je travaille actuellement sur un projet dans lequel j'utilise des macro pour créer des configurations de trait différentes. Voici mon code pour créer un trait rouge épaisseur 2 sans transparence.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
 
ActiveSheet.Shapes.AddLine(15309.75, 6#, 15351.75, 6#).Select
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.ForeColor.RGB = RGB(204, 0, 0)
    Selection.ShapeRange.Line.Transparency = 0
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.Weight = 2
    Selection.ShapeRange.Line.DashStyle = msoLineSolid 'Trait plein
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.SetShapesDefaultProperties
    Selection.ShapeRange.Line.Visible = msoTrue

Je voudrais créer un trait double mais je ne trouve pas le code qui me permettrait de le réaliser. Quelqu'un à peut être une idée?

Merci par avance.

Invité · 03/02/2014, 07h21

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 :

Sélectionner tout - Visualiser dans une fenêtre à part

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.

**ced25870** · 03/02/2014, 11h57

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