VBA Catia - Cotation automatique

**gwle21** · 09/11/2020, 16h33

Bonjour à tous,

Je suis actuellement en train de créer un macro VBA qui devra automatiquement créer des plans de pièces. Or au moment d'ajouter des côtes sur mes vues, je bloque totalement.
Connaissez-vous une solution de générer des côtes? Que ce soit en créant chaque côte avec la macro ou en utilisant l'outils "Génération de côtes" grâce à la macro ?

Merci d'avance

Invité · 09/11/2020, 17h24

Envoyé par gwle21

Bonjour,

Il y a pas mal d'années, je m'étais fait un logiciel pour construire des postes de transformation électrique dans des locaux mis à disposition dans des immeubles collectifs. Parfois les surfaces mises à disposition étaient franchement mal "fichues" et il fallait fournir aux architectes, des réservations cotées pour mettre les différents accessoires.

Le vidage d'écran ci-dessous montre différentes formes de cotation.

Important : Vous devrez peut-être réaliser une correction d'échelle entre la verticale et l'horizontale si le plan doit être utilisé strictement à l'échelle. Je ne me rappelle plus si cela venait de l'écran ou de l'imprimante.

Pièce jointe 583472

Dans l'onglet Cotation du Multipage du Userform :

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
 
' Onglet Cotation
Private Sub BoutonFleche1_Click()
 
        MiseALEchelle CSng(TextBoxEchelle)
 
        If OptionHorizontal = True Then
           FlecheHorizontal TextLongFleche.Value, "Horizontal"
        Else
          FlecheHorizontal TextLongFleche.Value, "Vertical"
        End If
 
End Sub
 
Private Sub BoutonFleche2_Click()
 
        MiseALEchelle CSng(TextBoxEchelle)
 
        Select Case OptionHorizontal.Value
          Case True
              If OptionGaucheHaut.Value = True Then FlecheType2 TextLongFleche.Value, "Horizontal", "Gauche"
              If OptionGaucheHaut.Value = False Then FlecheType2 TextLongFleche.Value, "Horizontal", "Droite"
          Case Else
              If OptionGaucheHaut.Value = True Then FlecheType2 TextLongFleche.Value, "Vertical", "Haut"
              If OptionGaucheHaut.Value = False Then FlecheType2 TextLongFleche.Value, "Vertical", "Bas"
        End Select
 
End Sub

Dans un module standard :

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
 
 
Sub FlecheType2(LongueurFleche, OrientationFleche, PositionEcriture)
 
Dim Nom1 As Variant
Dim Nom2 As Variant
Dim Nom3 As Variant
Dim Nom4 As Variant
 
Dim ObjetRange As ShapeRange
Dim NbFlechesExistantes As Long
 
 
    Dim PosH, PosV, PosH1, PosH2, PosH3, PosH4, PosV1, PosV2, PosV3, PosV4 As Single
    Dim LongH1, LongH2, LongH3, LongH4, LongV1, LongV2, LongV3, LongV4 As Single
 
    NbFlechesExistantes = NbObjetsExistants("Fleche ")
 
    PosH = 100
    PosV = 50
 
    Select Case OrientationFleche
        Case "Horizontal"
          If PositionEcriture = "Gauche" Then
            PosH1 = PosH - 30
            PosV1 = PosV
            LongH1 = PosH + 10 + LongueurFleche * RHorizontal
            LongV1 = PosV
 
            PosH2 = PosH - 4
            PosV2 = PosV - 6
            LongH2 = PosH + 4
            LongV2 = PosV + 6
 
            PosH3 = PosH - 4 + LongueurFleche * RHorizontal
            PosV3 = PosV - 6
            LongH3 = PosH + 4 + LongueurFleche * RHorizontal
            LongV3 = PosV + 6
 
            PosH4 = PosH - 30
            PosV4 = PosV - 15
            LongH4 = 20
            LongV4 = 15
          End If
          If PositionEcriture = "Droite" Then
            PosH1 = PosH - 10
            PosV1 = PosV
            LongH1 = PosH + 30 + LongueurFleche * RHorizontal
            LongV1 = PosV
 
            PosH2 = PosH - 4
            PosV2 = PosV - 6
            LongH2 = PosH + 4
            LongV2 = PosV + 6
 
            PosH3 = PosH - 4 + LongueurFleche * RHorizontal
            PosV3 = PosV - 6
            LongH3 = PosH + 4 + LongueurFleche * RHorizontal
            LongV3 = PosV + 6
 
            PosH4 = PosH + 10 + LongueurFleche * RHorizontal
            PosV4 = PosV - 15
            LongH4 = 20
            LongV4 = 15
          End If
 
        Case "Vertical"
 
          If PositionEcriture = "Haut" Then
            PosH1 = PosH
            PosV1 = PosV - 30
            LongH1 = PosH
            LongV1 = PosV + 10 + LongueurFleche * RVertical
 
            PosH2 = PosH - 6
            PosV2 = PosV - 4
            LongH2 = PosH + 6
            LongV2 = PosV + 4
 
            PosH3 = PosH - 6
            PosV3 = PosV - 4 + LongueurFleche * RVertical
            LongH3 = PosH + 6
            LongV3 = PosV + 4 + LongueurFleche * RVertical
 
            PosH4 = PosH - 20
            PosV4 = PosV - 35
            LongH4 = 25
            LongV4 = 30
          End If
 
          If PositionEcriture = "Bas" Then
            PosH1 = PosH
            PosV1 = PosV - 10
            LongH1 = PosH
            LongV1 = PosV + 30 + LongueurFleche * RVertical
 
            PosH2 = PosH - 6
            PosV2 = PosV - 4
            LongH2 = PosH + 6
            LongV2 = PosV + 4
 
            PosH3 = PosH - 6
            PosV3 = PosV - 4 + LongueurFleche * RVertical
            LongH3 = PosH + 6
            LongV3 = PosV + 4 + LongueurFleche * RVertical
 
            PosH4 = PosH - 15
            PosV4 = PosV + LongueurFleche * RVertical + 10
            LongH4 = 45
            LongV4 = 50
          End If
 
    End Select
 
 
        ActiveSheet.Shapes.AddLine(PosH1, PosV1, LongH1, LongV1).Select
       ' Selection.Name = "Trait1"
        Selection.Name = "Fleche" & CStr(NbFlechesExistantes) & "1"
        Nom1 = Selection.Name
 
        ActiveSheet.Shapes.AddLine(PosH2, PosV2, LongH2, LongV2).Select
        Selection.ShapeRange.Flip msoFlipVertical
        Selection.Name = "Fleche" & CStr(NbFlechesExistantes) & "2"
        Nom2 = Selection.Name
 
        ActiveSheet.Shapes.AddLine(PosH3, PosV3, LongH3, LongV3).Select
        Selection.ShapeRange.Flip msoFlipVertical
        Selection.Name = "Fleche" & CStr(NbFlechesExistantes) & "3"
        Nom3 = Selection.Name
 
     '   ActiveSheet.Shapes.Range(Array(Nom1, Nom2, Nom3)).Select
     '   Selection.ShapeRange.Group.Select
     '   Selection.Name = "Fleche1"
 
        ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosH4, PosV4, LongH4, LongV4).Select
        Selection.Name = "Fleche" & CStr(NbFlechesExistantes) & "4"
        Nom4 = Selection.Name
 
     '   Selection.Name = "FTexte1"
        Selection.Characters.Text = LongueurFleche
        With Selection.Characters(Start:=1, Length:=10).Font
            .Name = "Arial"
            .FontStyle = "Gras"
            .Color = RGB(0, 0, 0)
            .Size = 8
        End With
        Selection.ShapeRange.Fill.Visible = msoFalse
        Selection.ShapeRange.Line.Visible = msoFalse
        With Selection
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
            .Orientation = xlHorizontal
            .AutoSize = False
        End With
 
        If OrientationFleche = "Vertical" Then Selection.Orientation = xlUpward
 
 
        Set ObjetRange = ActiveSheet.Shapes.Range(Array(Nom1, Nom2, Nom3, Nom4))
        ObjetRange.Group.Select
        Selection.Name = "Fleche " & CStr(NbFlechesExistantes)
        ObjetRange.ZOrder msoBringToFront
        Set ObjetRange = Nothing
 
 
 
End Sub

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
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
 
 
Sub FlecheHorizontal(LongueurFleche As Long, OrientationFleche As String)
 
 Dim PosH1, PosV1 As Single
 Dim NbObjets As Long
 
   NbObjets = ActiveSheet.Shapes.Count + 1
 
   If OrientationFleche = "Vertical" Then
        PosH1 = 50
        PosV1 = 100
        ActiveSheet.Shapes.AddLine(PosH1, PosV1, PosH1, PosV1 + LongueurFleche * RVertical).Select
        Selection.Name = "Fleche" & NbObjets
        ChoisirStyleFleche
        FlecheTexteVertical LongueurFleche, PosH1, PosV1, LongueurFleche + RVertical
        Selection.Name = "FTexte" & NbObjets
        Selection.Font.Color = RGB(0, 0, 0)
   End If
 
   If OrientationFleche = "Horizontal" Then
 
        PosH1 = 100
        PosV1 = 50
        ActiveSheet.Shapes.AddLine(PosH1, PosV1, PosH1 + LongueurFleche * RHorizontal, PosV1).Select
        Selection.Name = "Fleche" & NbObjets
        ChoisirStyleFleche
        FlecheTexteHorizontal LongueurFleche, PosH1, PosV1, LongueurFleche + RHorizontal
        Selection.Name = "FTexte" & NbObjets
        Selection.Font.Color = RGB(0, 0, 0)
   End If
 
    ActiveSheet.Shapes.Range(Array("Fleche" & NbObjets, "FTexte" & NbObjets)).Select
    Selection.ShapeRange.Group.Select
 
 
End Sub
 
Sub FlecheTexteVertical(ContenuTexte, PosH, PosV, LongV)
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosH - 15, PosV, 16, LongV * RVertical).Select
    Selection.Characters.Text = ContenuTexte
    With Selection.Characters(Start:=1, Length:=10).Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 8
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .Orientation = xlUpward
    End With
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
End Sub
 
Sub ChoisirStyleFleche()
 
   With Selection.ShapeRange.Line
        .ForeColor.SchemeColor = 64
        .BeginArrowheadLength = msoArrowheadLengthMedium
        .BeginArrowheadWidth = msoArrowheadWidthMedium
        .BeginArrowheadStyle = msoArrowheadTriangle
        .EndArrowheadLength = msoArrowheadLengthMedium
        .EndArrowheadWidth = msoArrowheadWidthMedium
        .EndArrowheadStyle = msoArrowheadTriangle
   End With
 
End Sub
 
 
Sub FlecheTexteHorizontal(ContenuTexte, PosH, PosV, LongV)
    ActiveSheet.Shapes.AddShape(msoShapeRectangle, PosH, PosV - 15, LongV * RHorizontal, 16).Select
    Selection.Characters.Text = ContenuTexte
    With Selection.Characters(Start:=1, Length:=10).Font
        .Name = "Arial"
        .FontStyle = "Gras"
        .Size = 8
    End With
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    Selection.ShapeRange.Fill.Visible = msoFalse
    Selection.ShapeRange.Line.Visible = msoFalse
End Sub

VBA Catia - Cotation automatique

VBA

Discussions similaires

Partager

Partager