ViewVC Help
View File | Revision Log | Show Annotations | View Changeset | Root Listing
root/REPOS_ERICCA/magicsld/Intersections.vb
Revision: 130
Committed: Wed Jul 30 21:26:03 2008 UTC (16 years, 9 months ago) by bournival
File size: 108734 byte(s)
Log Message:
Une mise à jour, car on aura peut-être besoin de mon code.

File Contents

# Content
1 Imports SolidWorks.Interop
2 Imports SolidWorks.Interop.swconst
3 Imports SolidWorks.Interop.swpublished
4
5 Module Intersections
6 Public DefAttrInterALAL As SldWorks.AttributeDef
7 Public DefAttrConditionLimite As SldWorks.AttributeDef
8 Public DefAttrRCP1 As SldWorks.AttributeDef
9 Public DefAttrRCCoque As SldWorks.AttributeDef
10 Public DefAttrFaceInterne As SldWorks.AttributeDef
11 Public DefAttrDoublon As SldWorks.AttributeDef
12 Public DefAttrIgnorer As SldWorks.AttributeDef
13
14 Public nbMinipoutre As Long
15
16 Public lst_InterCoqueCoque As New Collections.Generic.List(Of InterCoqueCoque)
17
18 Public MettreMiniPoutresSurFaceInternes As Boolean
19 Public MultiDecoupageCoques As Boolean = False
20
21 #Region "Enums"
22 Public Enum typeInterPoutreVolume
23 Centre = 0
24 Sur_arete = 1
25 Sur_sommet = 2
26 Courbe = 3
27 End Enum
28
29 #End Region
30
31
32 Public Sub Debuter(Optional ByRef nom2 As String = "C:\Documents and Settings\Sylvain Bournival\Bureau\testMAGiC.sldprt", Optional ByVal nomFichier As String = "", Optional ByRef original As Boolean = True, Optional ByRef modifie As Boolean = True)
33
34 ' *******
35 ' quelques options de performance
36 ' *******
37 swApp.SetUserPreferenceIntegerValue(swconst.swUserPreferenceIntegerValue_e.swAutoSaveInterval, 0)
38 swModel.SetAddToDB(True)
39 swModel.SetDisplayWhenAdded(False)
40 swModel.SetInferenceMode(False)
41 ' ******
42 ' fin des options de performance
43 ' ******
44
45 Memoriser3iemePoint() ' mémorise le coord system car si on découpe, sa coordonnée est perdue.
46
47 CouperPoutres()
48 Commun.GenererListes() ' va ignorer les poutres à ignorer... et ajouter les poutres coupées dans la liste.
49
50
51
52 ' Traitement des intersection poutres-Volumes
53 DetectionPoutresVolumes() ' doit être avant interpoutreCoque au cas où on aurait une poutre de section
54 DecouperPoutreVolume()
55 ' fin traitement intersection poutres-volumes
56
57 swModel.EditRebuild3()
58
59
60
61 ' Traitement des intersection entre poutre et coques
62 DetectionPoutresCoques()
63 DecouperPoutreCoque()
64 ' Fin du traitement des intersections entre poutre et coques
65
66
67 ' traitement des coques-volumes
68 DetectionCoqueVolume()
69 DécouperCoqueVolume()
70 ' fin traitement coque volume
71
72 ' traitement des coques-coques
73 DetectionCoqueCoque()
74 DecouperCoqueCoque()
75 '
76
77
78
79 ' *******
80 ' quelques options de performance, remettre à la position initiale
81 ' *******
82 swApp.SetUserPreferenceIntegerValue(swconst.swUserPreferenceIntegerValue_e.swAutoSaveInterval, 15)
83 swModel.SetAddToDB(False)
84 swModel.SetDisplayWhenAdded(True)
85 swModel.GraphicsRedraw2()
86 swModel.SetInferenceMode(True)
87 ' ******
88 ' fin des options de performance
89 ' ******
90 ReplacerFolder()
91
92
93 End Sub
94
95
96 ''' <summary>
97 ''' Sub qui découpe les coques en fonction des informations placées dans le InterCoqueCoque
98 ''' </summary>
99 ''' <remarks></remarks>
100 Private Sub DecouperCoqueCoque()
101 Dim rayon As Double
102
103 For Each interCC As InterCoqueCoque In lst_InterCoqueCoque
104 'rayon = IIf(Coque Is interCC.sFaceCoque1, interCC.sFaceCoque2.GetEpaisseur, interCC.sFaceCoque1.GetEpaisseur)
105
106 If interCC.DoitCouperCoque1 Then
107 rayon = interCC.sFaceCoque2.GetEpaisseur / 2
108 Dim sweep As sldworks.Body2 = interCC.GénérerSweep(interCC.sketch, rayon)
109 interCC.DecouperCoque(interCC.sFaceCoque1, sweep)
110 If Intersections.MettreMiniPoutresSurFaceInternes Then interCC.MarquerFacesInternes(interCC.sFaceCoque2, interCC.sFaceCoque1)
111 End If
112
113 If interCC.DoitCouperCoque2 Then
114 rayon = interCC.sFaceCoque1.GetEpaisseur / 2
115 Dim sweep As sldworks.Body2 = interCC.GénérerSweep(interCC.sketch, rayon)
116 interCC.DecouperCoque(interCC.sFaceCoque2, sweep)
117 If Intersections.MettreMiniPoutresSurFaceInternes Then interCC.MarquerFacesInternes(interCC.sFaceCoque1, interCC.sFaceCoque2)
118 End If
119
120 If interCC.FaceAPlat Then
121 interCC.CoupeAPlat()
122 End If
123
124 ' reste à retrouver les faces internes.
125 'interCC.MarquerFacesInternes(IIf(Coque Is interCC.sFaceCoque1, interCC.sFaceCoque2, interCC.sFaceCoque1), IIf(Coque Is interCC.sFaceCoque1, interCC.sFaceCoque1, interCC.sFaceCoque2))
126 Next
127
128
129 End Sub
130
131 'Private Sub DecouperCoqueCoque()
132 ' Dim rayon As Double
133
134
135 ' For Each Coque As SlyFaceCoque In Commun.lst_FaceCoque
136 ' For Each interCC As InterCoqueCoque In Coque.lst_InterCoqueCoque
137 ' rayon = IIf(Coque Is interCC.sFaceCoque1, interCC.sFaceCoque2.GetEpaisseur, interCC.sFaceCoque1.GetEpaisseur)
138 ' Dim sweep As SldWorks.Body2 = interCC.GénérerSweep(interCC.sketch, rayon)
139 ' interCC.DecouperCoque(Coque, sweep)
140
141 ' ' reste à retrouver les faces internes.
142 ' interCC.MarquerFacesInternes(IIf(Coque Is interCC.sFaceCoque1, interCC.sFaceCoque2, interCC.sFaceCoque1), IIf(Coque Is interCC.sFaceCoque1, interCC.sFaceCoque1, interCC.sFaceCoque2))
143 ' Next
144 ' Next
145
146
147 'End Sub
148
149
150
151 ''' <summary>
152 ''' sub qui créé une instance de la classe interCoqueCoque s'il y a une intersection de ce type
153 ''' </summary>
154 ''' <remarks></remarks>
155 Private Sub DetectionCoqueCoque()
156
157 Dim sketch As SldWorks.Sketch = Nothing
158 Dim interCC As InterCoqueCoque = Nothing
159 Dim Coque1 As SlyFaceCoque, Coque2 As SlyFaceCoque
160
161 For i As Integer = 0 To Commun.lst_FaceCoque.Count - 2 'For Each Coque1 As SlyFaceCoque In Commun.lst_FaceCoque
162 Coque1 = Commun.lst_FaceCoque.Item(i)
163 For j As Integer = i + 1 To Commun.lst_FaceCoque.Count - 1 ' For Each coque2 As SlyFaceCoque In lst_FaceCoque
164 Coque2 = Commun.lst_FaceCoque.Item(j)
165 If DetectFaceFace(Coque2.SwFace, Coque1.SwFace, True, sketch) Then
166 ' création de l'instance de interFace-face entre coque et coque
167
168 interCC = New InterCoqueCoque(Coque1, Coque2)
169 interCC.FaceDeSection = False
170 interCC.sketch = sketch
171 interCC.determineType()
172 lst_InterCoqueCoque.Add(interCC)
173
174 'Coque1.lst_InterCoqueCoque.Add(interCC)
175 'Coque2.lst_InterCoqueCoque.Add(interCC)
176 End If
177
178 Next j
179 Next i
180
181 End Sub
182
183
184 Private Sub ReplacerFolder()
185 ' on doit mettre les folders à la fin pour que ça marche dans MAGiC
186 'Si on ne met pas les attributs à la fin on est baisé...
187
188 Dim swFeat As SldWorks.Feature = Nothing
189 Dim nomdernier As String
190 Dim dansFolder As Boolean = False
191 Dim i As Integer = 0
192 Dim ok As Boolean = False
193 Dim SelMgr As SldWorks.SelectionMgr
194
195 'trouver le premier feature qui n'est pas un folder...
196 Do Until ok
197 swFeat = swModel.FeatureByPositionReverse(i)
198 nomdernier = swFeat.GetTypeName
199
200 If (nomdernier = "FtrFolder") Then
201 dansFolder = Not dansFolder
202 Else
203 If Not dansFolder Then ok = True
204 End If
205 i += 1
206 Loop
207
208 nomdernier = swFeat.Name
209
210 SelMgr = swModel.SelectionManager
211 If swModel.Extension.SelectByID2("Poutres", "FTRFOLDER", 0, 0, 0, False, 0, Nothing, 0) Then swModel.ReorderFeature("Poutres", nomdernier)
212 If swModel.Extension.SelectByID2("Coques", "FTRFOLDER", 0, 0, 0, False, 0, Nothing, 0) Then swModel.ReorderFeature("Coques", nomdernier)
213 If swModel.Extension.SelectByID2("Conditions Aux Limites", "FTRFOLDER", 0, 0, 0, False, 0, Nothing, 0) Then swModel.ReorderFeature("Conditions Aux Limites", nomdernier)
214 If swModel.Extension.SelectByID2("FaceInternes", "FTRFOLDER", 0, 0, 0, False, 0, Nothing, 0) Then swModel.ReorderFeature("FaceInternes", nomdernier)
215
216 End Sub
217
218
219 Public Sub RegisterAttribut()
220 Static nouveau As Boolean
221 'propriétés des intersections entre 2 poutres (Arete-libre Arête-libre)
222
223 If nouveau Then Exit Sub
224 Dim nom As String
225 Dim retval As Boolean
226
227 nom = "InterALAL"
228 DefAttrInterALAL = swApp.DefineAttribute(nom)
229 DefAttrInterALAL.AddParameter("X", swconst.swParamType_e.swParamTypeDouble, 0, 0)
230 DefAttrInterALAL.AddParameter("Y", swconst.swParamType_e.swParamTypeDouble, 0, 0)
231 DefAttrInterALAL.AddParameter("Z", swconst.swParamType_e.swParamTypeDouble, 0, 0)
232 DefAttrInterALAL.AddParameter("T", swconst.swParamType_e.swParamTypeDouble, -1, 0)
233 retval = DefAttrInterALAL.Register()
234 If retval = False Then MsgBox("Enregistrement raté pour le InterALAL")
235
236
237 nom = "ConditionLimite"
238 DefAttrConditionLimite = swApp.DefineAttribute(nom)
239 DefAttrConditionLimite.AddParameter("CL", swconst.swParamType_e.swParamTypeString, 0, 0)
240 retval = DefAttrConditionLimite.Register()
241 If retval = False Then MsgBox("Enregistrement raté pour le COndition Limite")
242
243
244 DefAttrRCP1 = swApp.DefineAttribute("Poutre1")
245 DefAttrRCP1.AddParameter("M", 1, 0, 0) ' 0 = double, 1 = string, 2 = integer
246 DefAttrRCP1.AddParameter("S", 1, 0, 0)
247 DefAttrRCP1.AddParameter("As", 0, 0, 0)
248 DefAttrRCP1.AddParameter("I1", 0, 0, 0)
249 DefAttrRCP1.AddParameter("I2", 0, 0, 0)
250 DefAttrRCP1.AddParameter("N3", 1, 0, 0) ' le nom du troisième point
251 DefAttrRCP1.AddParameter("X3", 0, 0, 0) ' le x du troisième point
252 DefAttrRCP1.AddParameter("Y3", 0, 0, 0) ' le y du troisième point
253 DefAttrRCP1.AddParameter("Z3", 0, 0, 0) ' le z du troisième point
254 DefAttrRCP1.AddParameter("D1", 0, 0, 0)
255 DefAttrRCP1.AddParameter("D2", 0, 0, 0)
256 DefAttrRCP1.AddParameter("D3", 0, 0, 0)
257 DefAttrRCP1.AddParameter("D4", 0, 0, 0)
258 DefAttrRCP1.AddParameter("D5", 0, 0, 0)
259 DefAttrRCP1.AddParameter("D6", 0, 0, 0)
260 DefAttrRCP1.AddParameter("Flag", 0, 0, 0)
261 retval = DefAttrRCP1.Register()
262 If retval = False Then MsgBox("Enregistrement raté pour le RCPoutre")
263
264 DefAttrRCCoque = swApp.DefineAttribute("Coque")
265 DefAttrRCCoque.AddParameter("M", 1, 0, 0) 'le matériau' 0 = double, 1 = string, 2 = integer
266 DefAttrRCCoque.AddParameter("Ep", 0, 0, 0) ' épaisseur
267 DefAttrRCCoque.AddParameter("Flag", 0, 0, 0) ' un flag pour les coques...
268 retval = DefAttrRCCoque.Register()
269 If retval = False Then MsgBox("Enregistrement raté pour le RCCoque")
270
271 DefAttrFaceInterne = swApp.DefineAttribute("FaceInterne")
272 DefAttrFaceInterne.AddParameter("FI", 0, 0, 0) ' la taille des éléments
273 DefAttrFaceInterne.AddParameter("Po", 0, 0, 0) ' =0 si poutre, =1 si coque
274 retval = DefAttrFaceInterne.Register()
275 If retval = False Then MsgBox("Enregistrement raté pour le FaceInterne")
276
277 DefAttrDoublon = swApp.DefineAttribute("Doublon")
278 DefAttrDoublon.AddParameter("Maitre", 1, 0, 0) ' le nom du maitre...
279 DefAttrDoublon.AddParameter("Sens", 0, 0, 0) ' -1 si dans le sens oposé
280 retval = DefAttrDoublon.Register()
281 If retval = False Then MsgBox("Enregistrement raté pour le Doublon")
282
283 nom = "Ignorer"
284 DefAttrIgnorer = swApp.DefineAttribute(nom)
285 DefAttrIgnorer.AddParameter("Rien", 0, 0, 0)
286 retval = DefAttrIgnorer.Register()
287 If retval = False Then MsgBox("Enregistrement raté pour le Ignorer")
288
289 nouveau = True
290
291 End Sub
292
293 Private Sub TraiteAPAP()
294 ' procédure plus utilisée.
295 ' procédure qui trouve les intersections entre les poutres et qui créé un attribut contenant les informations
296
297 ' en premier on efface les features attributs, pour ne pas avoir de doubles
298 Dim feat As SldWorks.Feature
299 feat = swPart.FirstFeature
300 Dim nextfeat As SldWorks.Feature
301
302 Do While Not feat Is Nothing
303 If Left(feat.Name, 9) = "InterAPAP" Then
304 nextfeat = feat.GetNextFeature
305 swModel.Extension.SelectByID2(feat.Name, "ATTRIBUTE", 0, 0, 0, False, 0, Nothing, 0)
306 swPart.EditDelete()
307 feat = nextfeat
308 Else
309 feat = feat.GetNextFeature
310 End If
311 Loop
312 ' faut aussi détruire les liste de points dans les poutres
313 ' ce qui suit n'est pas optimisé en temps d'exécution, mais en temps de programmation ;-)
314 ' j'aurais besoin d'un trouver qui retourne le sly... en fonction d'un feature(edge)
315 Dim p As SlyAretePoutre
316 For Each p In lst_AretePoutre
317 p.EffacerIntersection()
318 Next
319
320
321 ' ' fin de l'effacement des attributs
322 Dim swArete1 As SldWorks.Edge
323 Dim swArete2 As SldWorks.Edge
324 Dim SlyArete1 As SlyAretePoutre
325 Dim SlyArete2 As SlyAretePoutre
326
327 Dim xyz() As Double = Nothing
328 Dim pt As New InterPoutrePoutre
329 'Dim lst_pts As New Collection
330 Dim i As Long
331
332 Dim a1 As Integer
333 Dim a2 As Integer
334
335
336 For a1 = 0 To lst_AretePoutre.Count - 2
337 SlyArete1 = lst_AretePoutre.Item(a1)
338 swArete1 = SlyArete1.swArete
339
340 For a2 = a1 + 1 To lst_AretePoutre.Count - 1
341 SlyArete2 = lst_AretePoutre.Item(a2)
342 swArete2 = SlyArete2.swArete
343
344 If DetectAreteArete(swArete1, swArete2, xyz) Then ' intersection courbe-courbe
345 For i = 0 To CInt((UBound(xyz) + 1) / 4) Step 4 ' si y'a plus d'une intersection entre les 2 courbes...
346
347 Select Case isIntersect_milieu(swArete1, swArete2, xyz(i), xyz(i + 1), xyz(i + 2))
348 Case 1 ' la première courbe est coupée
349 pt = New InterPoutrePoutre
350 pt.Arete = swArete1
351 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
352 SlyArete1.AjouterPointAPAP(pt)
353 pt = Nothing
354 Case 2 ' la seconde courbe est coupée
355 pt = New InterPoutrePoutre
356 pt.Arete = swArete2
357 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
358 SlyArete2.AjouterPointAPAP(pt)
359 pt = Nothing
360 Case 3 ' les doux courbes sont coupées
361 pt = New InterPoutrePoutre
362 pt.Arete = swArete1
363 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
364 SlyArete1.AjouterPointAPAP(pt)
365 pt = Nothing
366 pt = New InterPoutrePoutre
367 pt.Arete = swArete2
368 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
369 SlyArete2.AjouterPointAPAP(pt)
370 pt = Nothing
371 End Select
372 Next i
373 End If
374
375 Next a2
376 Next a1
377 pt = Nothing
378 End Sub
379
380
381 Public Function DetectAreteArete(ByRef swArete1 As SldWorks.Edge, ByRef swArete2 As SldWorks.Edge, ByRef xyz() As Double) As Boolean
382 ' function qui détermine si 2 arêtes se touchent, si oui alors la fonction retourne vrai et le tableau XYZ contient le point d'intersection
383 xyz = Nothing
384 If swArete2 Is Nothing Then Exit Function
385 If swArete1 Is Nothing Then Exit Function
386
387 Dim swSommet As SldWorks.Vertex
388 Dim point1 As Object ' point début courbe 1
389 Dim point2 As Object ' point fin, courbe 1
390 Dim point3 As Object ' point début courbe 2
391 Dim point4 As Object ' point fin, courbe 2
392 Dim swCourbe1 As SldWorks.Curve
393 Dim swCourbe2 As SldWorks.Curve
394 Dim vIntersectPts As Object
395
396 swSommet = swArete1.GetStartVertex
397 If swSommet Is Nothing Then ' cercle fermé
398 point1 = swArete1.Evaluate(0)
399 point2 = point1
400 Else
401 point1 = swSommet.GetPoint
402 swSommet = swArete1.GetEndVertex
403 point2 = swSommet.GetPoint
404 End If
405
406 swSommet = swArete2.GetStartVertex
407 If swSommet Is Nothing Then
408 point3 = swArete2.Evaluate(0)
409 point4 = point3
410 Else
411 point3 = swSommet.GetPoint
412
413 swSommet = swArete2.GetEndVertex
414 point4 = swSommet.GetPoint
415 End If
416 swCourbe1 = swArete1.GetCurve
417 swCourbe2 = swArete2.GetCurve
418
419
420 vIntersectPts = swCourbe1.IntersectCurve(swCourbe2, point1, point2, point3, point4)
421
422 Try ' je déteste cette façon de procéder, mais il ne détecte pas que le vintersectpts est nothing, il le croit system.dbnull. Et je ne peut comparer avec ça.
423 xyz = vIntersectPts
424
425 If Not xyz Is Nothing Then
426 DetectAreteArete = True
427 Dim i As Integer
428 For i = 0 To ((UBound(xyz) + 1) / 4) - 1
429 Debug.Write("x" & i & " = " & xyz(i * 4) * 1000 & " mm")
430 Debug.Write("y" & i & " = " & xyz(i * 4) * 1000 & " mm")
431 Debug.Write("z" & i & " = " & xyz(i * 4) * 1000 & " mm")
432 Next i
433 Else
434 Return False
435 End If
436 Catch ex As Exception
437 DetectAreteArete = False
438 End Try
439
440 End Function
441
442 Public Function DetectAreteArete(ByRef swArete1 As SldWorks.Edge, ByRef swCourbe2 As SldWorks.Curve, ByRef xyz() As Double) As Boolean
443 ' function qui détermine si 2 arêtes se touchent, si oui alors la fonction retourne vrai et le tableau XYZ contient le point d'intersection
444 xyz = Nothing
445 If swArete1 Is Nothing Then Exit Function
446 Dim swSommet As SldWorks.Vertex
447 Dim point1 As Object ' point début courbe 1
448 Dim point2 As Object ' point fin, courbe 1
449 Dim point3 As Object ' point début courbe 2
450 Dim point4 As Object ' point fin, courbe 2
451 Dim swCourbe1 As SldWorks.Curve
452
453 Dim vIntersectPts As Object
454
455 swSommet = swArete1.GetStartVertex
456 If swSommet Is Nothing Then ' cercle fermé
457 point1 = swArete1.Evaluate(0)
458 point2 = point1
459 Else
460 point1 = swSommet.GetPoint
461 swSommet = swArete1.GetEndVertex
462 point2 = swSommet.GetPoint
463 End If
464
465
466
467 If Not swCourbe2.IsTrimmedCurve Then
468 Dim vP1 As Object, vP2 As Object
469 vP1 = swCourbe2.Evaluate(-9000)
470 vP2 = swCourbe2.Evaluate(9000)
471 swCourbe2 = swCourbe2.CreateTrimmedCurve2(vP1(0), vP1(1), vP1(2), vP2(0), vP2(1), vP2(2))
472 End If
473
474 If Not swCourbe2.IsTrimmedCurve Then
475 MsgBox("Ça plante, le trimmage n'a pas fonctionné...")
476 End If
477
478 Dim dpoint3 As Double, dpoint4 As Double, isClosed As Boolean, isPeriodic As Boolean
479 swCourbe2.GetEndParams(dpoint3, dpoint4, isClosed, isPeriodic)
480
481 point3 = swCourbe2.Evaluate(dpoint3)
482 point4 = swCourbe2.Evaluate(dpoint4)
483
484 swCourbe1 = swArete1.GetCurve
485
486 vIntersectPts = swCourbe1.IntersectCurve(swCourbe2, point1, point2, point3, point4)
487
488 Try ' je déteste cette façon de procéder, mais il ne détecte pas que le vintersectpts est nothing, il le croit system.dbnull. Et je ne peut comparer avec ça.
489 xyz = vIntersectPts
490
491 If Not xyz Is Nothing Then
492 DetectAreteArete = True
493 Dim i As Integer
494 For i = 0 To ((UBound(xyz) + 1) / 4) - 1
495 Debug.Write("x" & i & " = " & xyz(i * 4) * 1000 & " mm")
496 Debug.Write("y" & i & " = " & xyz(i * 4) * 1000 & " mm")
497 Debug.Write("z" & i & " = " & xyz(i * 4) * 1000 & " mm")
498 Next i
499 Else
500 Return False
501 End If
502 Catch ex As Exception
503 DetectAreteArete = False
504 End Try
505
506 End Function
507
508 Private Function isIntersect_milieu(ByRef Arete1 As SldWorks.Edge, ByRef Arete2 As SldWorks.Edge, ByRef x As Double, ByRef y As Double, ByRef z As Double) As Byte
509 'procédure qui dit si les courbes s'intersectent au milieu ou à leurs point d'extrémité.
510 ' 0 si les deux intersections sont sur des points
511 ' 1 si la première courbe est coupée
512 ' 2 si la deuxième est coupée
513 ' 3 si les deux courbes sont coupées
514
515
516 Dim retv As Object ' mettre les valeurs de T dans la classe
517
518 retv = Arete1.GetCurveParams2() ' retv 0,1,2 point de départ, 3,4,5 point final
519 If (Math.Abs(retv(0) - x) < Epsilon) And (Math.Abs(retv(1) - y) < Epsilon) And (Math.Abs(retv(2) - z) < Epsilon) Or (Math.Abs(retv(3) - x) < Epsilon) And (Math.Abs(retv(4) - y) < Epsilon) And (Math.Abs(retv(5) - z) < Epsilon) Then isIntersect_milieu = 0 Else isIntersect_milieu = 1
520
521 retv = Arete2.GetCurveParams2() ' retv 0,1,2 point de départ, 3,4,5 point final
522 If (Math.Abs(retv(0) - x) < Epsilon) And (Math.Abs(retv(1) - y) < Epsilon) And (Math.Abs(retv(2) - z) < Epsilon) Or (Math.Abs(retv(3) - x) < Epsilon) And (Math.Abs(retv(4) - y) < Epsilon) And (Math.Abs(retv(5) - z) < Epsilon) Then isIntersect_milieu += 0 Else isIntersect_milieu += 2
523
524 End Function
525
526
527 ''' <summary>
528 ''' Sub qui traite les intersections entre les Poutres et les coques
529 ''' </summary>
530 ''' <remarks></remarks>
531 Private Sub DetectionPoutresCoques()
532 '#1 on détecte les intersections, on en a 4 types,
533 ' #1a) intersection au milieu de la coque
534 ' #1b) intersection sur une arête
535 ' #1c) intersection sur un sommet
536 ' #1d) intersection sur une certaine longueur
537 ' faut également faire attention, il peut y avoir plus d'une poutre qui se rejoint à la même intersection.
538 ' hypothèses: 1- les zones d'influence des poutres ne se croisent pas.
539 ' 2- une arête ne fait qu'une seule intersection, à un pount ou sur une ligne, mais pas à plusieurs endroits.
540 ' 3- une arête dont l'intersection est une courbe n'a pas d'autres intersections (pout l'instant)
541 ' lorsqu'une intersection est détectée on créé une instance de la classe InterPoutreCoque
542
543 Dim sPoutre As SlyAretePoutre
544 Dim sCoque As SlyFaceCoque
545 Dim inter As InterPoutreCoque
546 Dim xyz() As Double = Nothing
547 Dim tipe As Byte
548 Dim i As Integer
549 Dim premier2 As Boolean
550
551
552 For Each sCoque In lst_FaceCoque
553 For Each sPoutre In lst_AretePoutre
554 ' on cherche entre la coque et la poutre
555
556 If DetectFaceArete(sPoutre.swArete, sCoque.SwFace, xyz) Then
557 For i = 0 To UBound(xyz) - 1 Step 3
558 ' trouver le tipe d'intersection...
559
560 Dim u() As Double
561 Dim v() As Double
562
563 u = sPoutre.GetOrientation(xyz(i + 0), xyz(i + 1), xyz(i + 2))
564 v = sCoque.GetNormale(xyz(i + 0), xyz(i + 1), xyz(i + 2))
565
566 If Math.Abs((Math.Abs(Math.Acos(Outils_Math.cosdir(u, v))) - Pi / 2)) < Epsilon Then
567 ' on est dans le même plan que la coque, on doit déterminer si on sort ou entre dans la coque.
568 Dim T As Double, T1 As Double, T2 As Double
569 Dim PointTest(2) As Double
570 T = sPoutre.GetT(xyz(i + 0), xyz(i + 1), xyz(i + 2))
571
572 ' on fait T + ou - 15 * epsilon. si une valeur est dans la coque alors on considère que l'on a le type 2
573 ' on prend 15 fois epsilon car à 10, la fonction de solidworks considère que l'on est tellement près que l'on est sur la face
574 T1 = T + 15 * Epsilon
575 T2 = T - 15 * Epsilon
576
577 Dim effacer As Double
578
579 If sPoutre.Evaluer(T1, PointTest) Then
580 ' la valeur de T appartient à la poutre, maintenant on vérifie s'il appartient aussi à la coque
581 If Distance(sCoque.lst_Faces.Item(0), PointTest(0), PointTest(1), PointTest(2)) < Epsilon Then
582 ' on est dans la coque.
583 If Not premier2 Then tipe = 2 : premier2 = True Else tipe = 22
584 End If
585 End If
586
587 If sPoutre.Evaluer(T2, PointTest) Then
588 effacer = Distance(sCoque.lst_Faces.Item(1), PointTest(0), PointTest(1), PointTest(2))
589 If Distance(sCoque.lst_Faces.Item(1), PointTest(0), PointTest(1), PointTest(2)) < Epsilon Then
590 If Not premier2 Then tipe = 2 : premier2 = True Else tipe = 22
591 End If
592 End If
593
594
595 ' si tipe n'est pas à 2 alors on est par défaut à 3
596 If tipe = 0 Then tipe = 3
597
598 Else
599 tipe = 1 ' on va devoir couper en X
600 End If
601
602 inter = sCoque.AjouterInterPoutre(sPoutre, xyz, tipe)
603 sPoutre.lst_InterCoque.Add(inter)
604 tipe = 0 ' reset
605
606 Next i ' autre point d'intersection
607
608 End If
609 premier2 = False ' reset
610 Next sPoutre
611 Next sCoque
612 End Sub
613
614
615
616 ''' <summary>
617 ''' Sub qui procède au découpage des coques en fonction des poutres
618 ''' </summary>
619 ''' <remarks></remarks>
620 Private Sub DecouperPoutreCoque()
621 ' #2 on procède au découpage de la face
622 Dim sCoque As SlyFaceCoque
623 For Each sCoque In lst_FaceCoque
624 If sCoque.lst_InterPoutre.Count > 0 Then
625 'sVol.chercherAttributs()
626 sCoque.decouper()
627
628 ' on met-a-jour l'attribut des conditions aux limites
629 Dim attr As SldWorks.Attribute
630 Dim swent As SldWorks.Entity
631 Dim nom3 As String = Nothing
632 Dim p As SldWorks.Parameter
633 If Not sCoque.AttributCL Is Nothing Then
634 nom3 = "CL_" & sCoque.nom
635 swent = sCoque.lst_Faces.Item(1)
636 attr = swent.FindAttribute(Intersections.DefAttrConditionLimite, 0) ' si l'attribut existe déjà on pointe dessus.
637
638 If attr Is Nothing Then attr = Intersections.DefAttrConditionLimite.CreateInstance5(swModel, sCoque.lst_Faces.Item(1), nom3, 0, 0)
639 p = attr.GetParameter("CL")
640 p.SetStringValue(sCoque.condition)
641
642 End If
643 GererDossiers("Conditions Aux Limites", nom3)
644 End If
645
646 Next
647 End Sub
648
649
650 ''' <summary>
651 ''' Sub qui détecte les intersections entre les faces du volume et les poutres
652 ''' </summary>
653 ''' <remarks></remarks>
654 Private Sub DetectionPoutresVolumes()
655 Dim sPoutre As SlyAretePoutre
656
657 For Each sPoutre In lst_AretePoutre
658 If Not sPoutre.IsFaceDeSection Then
659 Call Intersections.GestionPoutreNormaleAvecVolume(sPoutre)
660 Else
661 ' la poutre est flaggée pour prendre la face de section
662 Call Intersections.GestionFace_De_section(sPoutre)
663 End If
664 Next sPoutre
665 End Sub
666
667 ''' <summary>
668 ''' Sub qui prend les intersections entre les faces et les volumes et qui coupe les volumes
669 ''' </summary>
670 ''' <remarks></remarks>
671 Private Sub DecouperPoutreVolume()
672 ' #2 on procède au découpage de la face
673 Dim sVol As SlyFaceVolume
674
675 For Each sVol In lst_FaceVolume
676 If sVol.lst_InterPoutre.Count > 0 Then
677 sVol.decouper()
678
679 ' on met-a-jour l'attribut des conditions aux limites
680 Dim attr As SldWorks.Attribute
681 Dim swent As SldWorks.Entity
682 Dim nom3 As String = Nothing
683 Dim p As SldWorks.Parameter
684 If Not sVol.AttributCL Is Nothing Then
685 nom3 = "CL_" & sVol.nom
686 swent = sVol.SwFace
687 attr = swent.FindAttribute(Intersections.DefAttrConditionLimite, 0) ' si l'attribut existe déjà on pointe dessus.
688
689 If attr Is Nothing Then attr = Intersections.DefAttrConditionLimite.CreateInstance5(swModel, sVol.SwFace, nom3, 0, 0)
690 p = attr.GetParameter("CL")
691 p.SetStringValue(sVol.condition)
692
693 End If
694 GererDossiers("Conditions Aux Limites", nom3)
695 End If
696
697 Next
698 End Sub
699
700
701
702
703
704 ''' <summary>
705 ''' Sub qui gère la poutre qui a été flaggée comme ayant une face de section. Met à jour les attributs avec les bonnes inerties et autre
706 ''' </summary>
707 ''' <param name="sPoutre">La poutre avec laquelle il faut travailler</param>
708 ''' <remarks></remarks>
709 Private Sub GestionFace_De_section(ByRef sPoutre As SlyAretePoutre)
710
711 Dim sVol As SlyFaceVolume
712 Dim swExt As SldWorks.ModelDocExtension
713 Dim xyz() As Double = Nothing, xyz2() As Double = Nothing
714 Dim section As Object
715 Dim Face1 As SlyFaceVolume = Nothing, prop1() As Double = Nothing
716 Dim Face2 As SlyFaceVolume = Nothing, prop2() As Double = Nothing
717 Dim proprietes() As Double
718 Dim i As Integer
719 swExt = swModel.Extension
720
721 ' 1 - Spotter la ou les faces en question
722 xyz = sPoutre.GetStartPoint
723 xyz2 = sPoutre.GetEndPoint
724
725 For Each sVol In Commun.lst_FaceVolume
726 If Intersections.DetectSurfaceArete(sPoutre.swArete, sVol.SwFace, Nothing) Then
727 swModel.ClearSelection2(True)
728 sVol.Selectionner()
729 section = swExt.GetSectionProperties2(sVol.SwFace) : proprietes = section
730 swModel.ClearSelection2(True)
731 ' la fonction getsectionproperties renvoie des valeurs dont la précision est très douteuse...
732 ' on met alors une beaucoup plus grosse tolérance...
733 If Math.Abs(xyz(0) - proprietes(2)) < 0.0001 And Math.Abs(xyz(1) - proprietes(3)) < 0.0001 And Math.Abs(xyz(2) - proprietes(4)) < 0.0001 Then
734 Face1 = sVol : prop1 = proprietes
735 ElseIf Math.Abs(xyz2(0) - proprietes(2)) < 0.0001 And Math.Abs(xyz2(1) - proprietes(3)) < 0.0001 And Math.Abs(xyz2(2) - proprietes(4)) < 0.0001 Then
736 Face2 = sVol : prop2 = proprietes
737 Else
738 ' on a une intersection où la poutre touche à une face «guide» et une autre partie touche à une face normale
739 ' la face est automatiquement une face de volume. Si c'est une coque, elle est traitée ailleurs.
740
741 'Dim interNormale As InterPoutreVolume
742 'Dim point1 As Object = Nothing
743 'swModel.ClosestDistance(sPoutre.swArete, sVol.SwFace, point1, Nothing)
744 'Dim xyzNormale() As Double = point1
745 'interNormale = sVol.AjouterInterPoutre(sPoutre, xyzNormale, 6) ' y'a des cas où ça pourrait ne pas être 1...
746 'sPoutre.lst_InterCoque.Add(interNormale)
747
748 End If
749
750 End If
751 Next
752
753 ' si les 2 faces sont nothing, c'est que l'on a un sérieux problème...
754 If Face1 Is Nothing AndAlso Face2 Is Nothing Then
755 MsgBox("La poutre " & sPoutre.nom & " doit avoir au moins une face pour évaluer sa section. Cette face n'a pas été trouvée." & vbCr & vbCr & " Vérifiez que: " & vbCr & " - Un sommet de la poutre repose sur le centre de gravité d'une face" & vbCr & " - Que l'arète de la poutre est perpendiculaire à la face" & vbCr & " - Que la face est plane " & vbCr & " - Je crois avoir tout couvert..." & vbCr & vbCr & " La poutre a problème a été colorée en rouge.", MsgBoxStyle.Critical, "Impossible de trouver la face représentant la section")
756 Dim e As New SuperArete(sPoutre.swArete, True)
757 e.Colorer(3, 1, 0, 0)
758 sPoutre.Selectionner()
759 Err.Raise(520, "Gestion_Face_De_Section", "Une poutre ne peut être traitée car elle n'a pas été correctement définie.")
760 Exit Sub
761 End If
762
763
764
765 ' 2 - s'assurer que:
766 ' 2.1 les 2 faces sont identiques (si 2 faces)
767 If Face1 IsNot Nothing And Face2 IsNot Nothing Then
768 If Not Math.Abs(prop1(1) - prop2(1)) < 0.0000001 Then
769 Dim chaine As String
770 chaine = "Les 2 faces ne sont pas identiques... "
771 For i = 0 To 14
772 chaine = chaine & vbCr & i & " - " & Format(prop1(i), "0.000E+00") & " " & Format(prop2(i), "0.000E+00")
773 Next i
774 MsgBox(chaine)
775 End If
776 End If
777 ' 2.2 le centroide est au point d'intersection
778 ' déjà fait
779 ' 2.3 la face est plane
780 Dim prop() As Double = Nothing
781
782 If Face1 IsNot Nothing Then
783 prop = prop1
784 If Not (Face1.estPlan Xor Face1.estFauxPlan(prop1(2), prop1(3), prop1(4))) Then
785 MsgBox("La face 1 n'est pas plane!")
786 Err.Raise(513, , "Ne peut pas prendre une face non plane comme source de la section de la poutre")
787 End If
788 End If
789 If Face2 IsNot Nothing Then
790 prop = prop2
791 If Not (Face2.estPlan Xor Face2.estFauxPlan(prop2(2), prop2(3), prop2(4))) Then
792 MsgBox("La face 2 n'est pas plane!")
793 Err.Raise(513, , "Ne peut pas prendre une face non plane comme source de la section de la poutre")
794 End If
795 End If
796
797
798 ' 2.4 les face sont perpendiculaire aux point d'intersection
799 Dim u() As Double
800 Dim v() As Double
801 Dim angle As Double
802 If Face1 IsNot Nothing Then
803 u = Face1.GetNormaleSurface(prop1(2), prop1(3), prop1(4))
804 v = sPoutre.GetOrientation(prop1(2), prop1(3), prop1(4))
805 angle = Outils_Math.Angle2Vecteurs(u, v)
806 If Not (Math.Abs(angle - Pi) < (100 * Epsilon)) And Not (angle < 0.005) Then
807 MsgBox("La poutre n'est pas perpendiculaire à la face1")
808 Err.Raise(514, "GestionFace_de_section - Dans intersection.vb", "Ne peut pas traiter une poutre dont la face de base n'est pas perpendiculaire")
809 End If
810 End If
811
812 If Face2 IsNot Nothing Then
813 u = Face2.GetNormaleSurface(prop2(2), prop2(3), prop2(4))
814 v = sPoutre.GetOrientation(prop2(2), prop2(3), prop2(4))
815 angle = Outils_Math.Angle2Vecteurs(u, v)
816 If Not (Math.Abs(angle - Pi) < (100 * Epsilon)) And Not (angle < Epsilon) Then
817 MsgBox("La poutre n'est pas perpendiculaire à la face2")
818 Err.Raise(514, "GestionFace_de_section - Dans intersection.vb", "Ne peut pas traiter une poutre dont la face de base n'est pas perpendiculaire")
819 End If
820 End If
821
822 ' 3 - trouver l'inertie et l'aire, placer le point 3 de façon cohérente, updater l'attribut.
823 Dim Nom3 As String
824
825 Commun.MettreUnPoint(prop(2) + prop(18) / 1000, prop(3) + prop(19) / 1000, prop(4) + prop(20) / 1000, True)
826 Dim selmgr As sldworks.SelectionMgr = swModel.SelectionManager
827 Nom3 = RealConstant.RCCode.Creation3iemePoint(selmgr.GetSelectedObject(1))
828 sPoutre.SetAttributsDePoutre(False, Nom3, , , prop(13), prop(14), prop(1), , , , , , , 1)
829
830 ' 4 créer une nouvelle instance de la classe interFacePoutre de tipe 5
831 Dim inter As New InterPoutreVolume
832 Dim inter2 As New InterPoutreVolume
833 If Face1 IsNot Nothing Then
834 xyz(0) = prop1(2) : xyz(1) = prop1(3) : xyz(2) = prop1(4)
835 inter = Face1.AjouterInterPoutre(sPoutre, xyz, 5)
836 sPoutre.lst_InterCoque.Add(inter)
837 End If
838
839 If Face2 IsNot Nothing Then
840 xyz(0) = prop2(2) : xyz(1) = prop2(3) : xyz(2) = prop2(4)
841 inter2 = Face2.AjouterInterPoutre(sPoutre, xyz, 5)
842 sPoutre.lst_InterCoque.Add(inter2)
843 End If
844
845 End Sub
846
847
848 ''' <summary>
849 ''' Sub qui trouve les intersections entre les poutres et les faces de volumes et qui créé une instance de la classe d'intersection
850 ''' </summary>
851 ''' <param name="sPoutre">La poutre avec laquelle il faut trouver les intersections</param>
852 ''' <remarks></remarks>
853 Private Sub GestionPoutreNormaleAvecVolume(ByRef sPoutre As SlyAretePoutre)
854 Dim inter As InterPoutreVolume
855 Dim xyz() As Double = Nothing
856 Dim tipe As Byte
857 Dim i As Integer
858 Dim premier2 As Boolean
859 Dim sVol As SlyFaceVolume
860 Dim SurSurface As Boolean = False
861
862 For Each sVol In lst_FaceVolume
863
864 ' on cherche entre la coque et la poutre
865 SurSurface = False
866 If DetectFaceArete(sPoutre.swArete, sVol, xyz, SurSurface) Then
867 For i = 0 To UBound(xyz) - 1 Step 3
868 ' trouver le tipe d'intersection...
869
870 Dim u() As Double
871 Dim v() As Double
872
873 u = sPoutre.GetOrientation(xyz(i + 0), xyz(i + 1), xyz(i + 2))
874 v = sVol.GetNormale(xyz(i + 0), xyz(i + 1), xyz(i + 2))
875
876 ' ***** ici, différencier entre coque et volume ****
877 If Math.Abs((Math.Abs(Math.Acos(Outils_Math.cosdir(u, v))) - Pi / 2)) < Epsilon Then
878 ' on est dans le même plan que la coque, on doit déterminer si on sort ou entre dans la coque.
879 Dim T As Double, T1 As Double, T2 As Double
880 Dim PointTest(2) As Double
881 T = sPoutre.GetT(xyz(i + 0), xyz(i + 1), xyz(i + 2))
882
883 ' on fait T + ou - 15 * epsilon. si une valeur est dans la coque alors on considère que l'on a le type 2
884 ' on prend 15 fois epxilon car à 10, la fonction de solidworks considère que l'on est tellement près que l'on est sur la face
885 T1 = T + 15 * Epsilon
886 T2 = T - 15 * Epsilon
887
888
889 If sPoutre.Evaluer(T1, PointTest) Then
890 ' la valeur de T appartient à la poutre, maintenant on vérifie s'il appartient aussi à la coque
891 If Distance(sVol.SwFace, PointTest(0), PointTest(1), PointTest(2)) < Epsilon Then
892 ' on est dans la coque.
893 If Not premier2 Then tipe = 2 : premier2 = True Else tipe = 22
894 End If
895 End If
896
897 If sPoutre.Evaluer(T2, PointTest) Then
898
899 If Distance(sVol.SwFace, PointTest(0), PointTest(1), PointTest(2)) < Epsilon Then
900 If Not premier2 Then tipe = 2 : premier2 = True Else tipe = 22
901 End If
902 End If
903
904 ' si tipe n'est pas à 2 alors on est par défaut à 3
905 If tipe = 0 Then tipe = 3
906
907 Else
908 tipe = 1 ' on va devoir couper en X
909 End If
910
911 inter = sVol.AjouterInterPoutre(sPoutre, xyz, tipe)
912 sPoutre.lst_InterCoque.Add(inter)
913 tipe = 0 ' reset
914
915 Next i ' autre point d'intersection
916
917 ElseIf SurSurface = True Then
918 ' Si les 2 points de la courbe touchent à la surface alors coupe-long
919 If Commun.Distance(sVol.SwFace, sPoutre.GetStartPoint()) < Epsilon AndAlso Commun.Distance(sVol.SwFace, sPoutre.GetEndPoint()) < Epsilon Then
920 inter = sVol.AjouterInterPoutre(sPoutre, xyz, 2)
921 sPoutre.lst_InterCoque.Add(inter)
922 End If
923 End If
924 premier2 = False ' reset
925
926 Next sVol
927 End Sub
928
929
930
931
932 'Private Function DetectFaceArete(ByRef swCurve As SldWorks.Curve, ByRef swFace As SldWorks.Face2, ByRef xyz() As Double) As Boolean
933 ' ' function qui détecte si une arête coupe une face, si c'est le cas la function retourne true et remplie le tableau xyz avec le point d'intersection
934 ' Dim vCurveParam As Object
935 ' Dim swSurf As SldWorks.Surface
936 ' Dim vCurveBounds As Object, vPointArray As Object, vTArray As Object, vUVArray As Object
937 ' Dim nCurveBounds(5) As Double
938 ' Dim bRet As Boolean
939 ' Dim i As Integer
940
941 ' swSurf = swFace.GetSurface
942
943 ' ' 2- on va chercher les paramètres de la spline avec Curve::ConvertLineToBcurve
944 ' If swCurve.IsLine Then
945 ' Dim startp(2) As Double
946 ' Dim endp(2) As Double
947 ' Dim vStart As Object
948 ' Dim vEnd As Object
949
950 ' vCurveParam = swCurve.LineParams()
951 ' startp(0) = vCurveParam(0)
952 ' startp(1) = vCurveParam(1)
953 ' startp(2) = vCurveParam(2)
954 ' vStart = startp
955
956 ' endp(0) = vCurveParam(3)
957 ' endp(1) = vCurveParam(4)
958 ' endp(2) = vCurveParam(5)
959 ' vEnd = endp
960
961 ' Dim retval As Object
962 ' Dim valeur As Double
963 ' Dim dimension As Integer
964 ' Dim ordre As Integer
965 ' Dim nbpoints As Integer
966 ' Dim periodique As Integer
967
968 ' retval = swCurve.ConvertLineToBcurve(vStart, vEnd)
969
970 ' ' on suppose que la droite est toujours transformée en spline non-rationelle de dimension 3 et d'ordre 2
971 ' Dim knots(3) As Double
972 ' Dim ctrlPoints(5) As Double
973
974 ' knots(0) = retval(2)
975 ' knots(1) = retval(3)
976 ' knots(2) = retval(4)
977 ' knots(3) = retval(5)
978
979 ' ctrlPoints(0) = retval(6)
980 ' ctrlPoints(1) = retval(7)
981 ' ctrlPoints(2) = retval(8)
982 ' ctrlPoints(3) = retval(9)
983 ' ctrlPoints(4) = retval(10)
984 ' ctrlPoints(5) = retval(11)
985
986 ' '3 - on créé une spline dans le modeleur
987
988
989 ' Dim modeler As SldWorks.Modeler
990 ' modeler = swApp.GetModeler
991 ' Dim props As Object
992 ' Dim dProps(1) As Double
993 ' Dim vKnots As Object, vCtrlPoints As Object
994
995 ' dProps(0) = retval(0)
996 ' dProps(1) = retval(1)
997 ' props = dProps
998 ' vKnots = knots
999 ' vCtrlPoints = ctrlPoints
1000
1001 ' swCurve = modeler.CreateBsplineCurve(props, vKnots, vCtrlPoints)
1002 ' ' 4 - on a une spline, on peut utiliser la fonction IntersectCurve
1003 ' End If
1004
1005
1006 ' For i = 0 To 5
1007 ' nCurveBounds(i) = vCurveParam(i)
1008 ' Next i
1009
1010 ' vCurveBounds = nCurveBounds
1011 ' bRet = swSurf.IntersectCurve(swCurve, vCurveBounds, vPointArray, vTArray, vUVArray)
1012
1013 ' Dim Pts() As Double
1014 ' Dim PointsTemp() As Double
1015 ' Dim j As Integer
1016
1017 ' Pts = vPointArray
1018
1019 ' If UBound(Pts) < 1 Then Return False
1020 ' ' ATTENTION, le point n'est pas nécessairement dans la face
1021 ' For i = 0 To UBound(Pts) - 1 Step 3
1022 ' If Commun.Distance(swFace, Pts(i + 0), Pts(i + 1), Pts(i + 2)) < Epsilon Then
1023 ' ReDim Preserve PointsTemp(j + 2)
1024 ' PointsTemp(j) = Pts(i + 0)
1025 ' PointsTemp(j + 1) = Pts(i + 1)
1026 ' PointsTemp(j + 2) = Pts(i + 2)
1027 ' j += 3
1028 ' End If
1029 ' Next
1030
1031 ' xyz = PointsTemp
1032 ' If xyz Is Nothing Then Return False
1033 ' If UBound(xyz) > 0 Then Return True
1034
1035
1036 'End Function
1037
1038 Private Function DetectFaceArete(ByRef swArete As SldWorks.Edge, ByRef swFace As SldWorks.Face2, ByRef xyz() As Double) As Boolean
1039 ' function qui détecte si une arête coupe une face, si c'est le cas la function retourne true et remplie le tableau xyz avec le point d'intersection
1040
1041 Dim P1 As Object = Nothing, p2 As Object = Nothing
1042 If swModel.ClosestDistance(swArete, swFace, P1, p2) > Epsilon Then Return False
1043
1044 Dim swCurve As SldWorks.Curve
1045 Dim swSurf As SldWorks.Surface
1046 Dim vCurveParam As Object
1047
1048 Dim vCurveBounds As Object, vPointArray As Object = Nothing, vTArray As Object = Nothing, vUVArray As Object = Nothing
1049 Dim nCurveBounds(5) As Double
1050 Dim bRet As Boolean
1051 Dim i As Integer
1052
1053 '1 - on va chercher la courbe et la surface
1054 swCurve = swArete.GetCurve
1055 swSurf = swFace.GetSurface
1056
1057
1058 ' 2- on va chercher les paramètres de la spline avec Curve::ConvertLineToBcurve
1059 vCurveParam = swArete.GetCurveParams2
1060 If swCurve.IsLine Then
1061 Dim startp(2) As Double
1062 Dim endp(2) As Double
1063 Dim vStart As Object
1064 Dim vEnd As Object
1065
1066
1067 startp(0) = vCurveParam(0)
1068 startp(1) = vCurveParam(1)
1069 startp(2) = vCurveParam(2)
1070 vStart = startp
1071
1072 endp(0) = vCurveParam(3)
1073 endp(1) = vCurveParam(4)
1074 endp(2) = vCurveParam(5)
1075 vEnd = endp
1076
1077 Dim retval As Object
1078
1079 retval = swCurve.ConvertLineToBcurve(vStart, vEnd)
1080
1081 ' on suppose que la droite est toujours transformée en spline non-rationelle de dimension 3 et d'ordre 2
1082 Dim knots(3) As Double
1083 Dim ctrlPoints(5) As Double
1084
1085 knots(0) = retval(2)
1086 knots(1) = retval(3)
1087 knots(2) = retval(4)
1088 knots(3) = retval(5)
1089
1090 ctrlPoints(0) = retval(6)
1091 ctrlPoints(1) = retval(7)
1092 ctrlPoints(2) = retval(8)
1093 ctrlPoints(3) = retval(9)
1094 ctrlPoints(4) = retval(10)
1095 ctrlPoints(5) = retval(11)
1096
1097 '3 - on créé une spline dans le modeleur
1098
1099
1100 Dim modeler As SldWorks.Modeler
1101 modeler = swApp.GetModeler
1102 Dim props As Object
1103 Dim dProps(1) As Double
1104 Dim vKnots As Object, vCtrlPoints As Object
1105
1106 dProps(0) = retval(0)
1107 dProps(1) = retval(1)
1108 props = dProps
1109 vKnots = knots
1110 vCtrlPoints = ctrlPoints
1111
1112 swCurve = modeler.CreateBsplineCurve(props, vKnots, vCtrlPoints)
1113 ' 4 - on a une spline, on peut utiliser la fonction IntersectCurve
1114 End If
1115
1116
1117 For i = 0 To 5
1118 nCurveBounds(i) = vCurveParam(i)
1119 Next i
1120
1121 vCurveBounds = nCurveBounds
1122 bRet = swSurf.IntersectCurve(swCurve, vCurveBounds, vPointArray, vTArray, vUVArray)
1123
1124 Dim Pts() As Double
1125 Dim PointsTemp() As Double = Nothing
1126 Dim j As Integer
1127
1128 Pts = vPointArray
1129
1130 If UBound(Pts) < 1 Then Return False
1131 ' ATTENTION, le point n'est pas nécessairement dans la face
1132 For i = 0 To UBound(Pts) - 1 Step 3
1133 If Commun.Distance(swFace, Pts(i + 0), Pts(i + 1), Pts(i + 2)) < Epsilon Then
1134 ReDim Preserve PointsTemp(j + 2)
1135 PointsTemp(j) = Pts(i + 0)
1136 PointsTemp(j + 1) = Pts(i + 1)
1137 PointsTemp(j + 2) = Pts(i + 2)
1138 j += 3
1139 End If
1140 Next
1141
1142 xyz = PointsTemp
1143 If xyz Is Nothing Then Return False
1144 If UBound(xyz) > 0 Then Return True
1145
1146 End Function
1147
1148
1149
1150 Private Function DetectFaceArete(ByRef swArete As sldworks.Edge, ByRef Slyface As SlyFaceVolume, ByRef xyz() As Double, Optional ByRef SurSurface As Boolean = False) As Boolean
1151 Dim swface As sldworks.Face2
1152
1153 For Each swface In Slyface.lst_Faces
1154 If DetectFaceArete(swArete, swface, xyz) Then
1155 Dim vEdges As Object
1156 Dim Arete As sldworks.Edge
1157 Dim inu() As Double = Nothing
1158
1159 vEdges = swface.GetEdges
1160
1161 For Each Arete In vEdges
1162 If DetectAreteArete(Arete, swArete, inu) Then
1163 ' on a un type d'intersection entre une face et une arète...
1164 Dim swSurf As sldworks.Surface
1165 Dim retval As Object
1166 Dim v(2) As Double
1167 Dim u(2) As Double
1168 Dim angle As Double
1169 swSurf = swface.GetSurface
1170 retval = swSurf.EvaluateAtPoint(xyz(0), xyz(1), xyz(2))
1171 ' les 3 premiers de retval sont la normale...
1172 v(0) = retval(0) : v(1) = retval(1) : v(2) = retval(2)
1173
1174 retval = swArete.GetParameter(inu(0), inu(1), inu(2))
1175 retval = swArete.Evaluate(retval(0))
1176 u(0) = retval(3) : u(1) = retval(4) : u(2) = retval(5)
1177 angle = Outils_Math.Angle2Vecteurs(u, v)
1178 'MsgBox(angle * 180 / Pi & "<-- angle sens --> " & swface.FaceInSurfaceSense & vbCr & "Aire = " & Slyface.Aire)
1179
1180
1181 'Si l'angle entre la normale de la face et la normale de la courbe est de 0
1182 ' ou de pi/2 alors on a une SurSurface
1183 If Math.Abs(angle - Pi / 2) < 100 * Epsilon Or Math.Abs(angle) < 100 * Epsilon Then
1184 SurSurface = True
1185 Else
1186 Return True
1187 End If
1188
1189 'If ((angle < (Pi / 2)) Xor swface.FaceInSurfaceSense()) Then
1190 ' Return True
1191 'Else
1192 ' SurSurface = True
1193 'End If
1194 End If
1195 Next
1196
1197
1198 If Not SurSurface Then Return True Else Return False
1199 End If
1200 Next
1201 End Function
1202
1203
1204
1205
1206 Private Function DetectSurfaceArete(ByRef swArete As SldWorks.Edge, ByRef swFace As SldWorks.Face2, ByRef xyz() As Double) As Boolean
1207 ' function qui détecte si une arête coupe une face, si c'est le cas la function retourne true et remplie le tableau xyz avec le point d'intersection
1208 Dim swCurve As SldWorks.Curve
1209 Dim swSurf As SldWorks.Surface
1210 Dim vCurveParam As Object
1211
1212 Dim vCurveBounds As Object, vPointArray As Object = Nothing, vTArray As Object = Nothing, vUVArray As Object = Nothing
1213 Dim nCurveBounds(5) As Double
1214 Dim bRet As Boolean
1215 Dim i As Integer
1216
1217 '1 - on va chercher la courbe et la surface
1218 swCurve = swArete.GetCurve
1219 swSurf = swFace.GetSurface
1220
1221
1222 ' 2- on va chercher les paramètres de la spline avec Curve::ConvertLineToBcurve
1223 vCurveParam = swArete.GetCurveParams2
1224 If swCurve.IsLine Then
1225 Dim startp(2) As Double
1226 Dim endp(2) As Double
1227 Dim vStart As Object
1228 Dim vEnd As Object
1229
1230
1231 startp(0) = vCurveParam(0)
1232 startp(1) = vCurveParam(1)
1233 startp(2) = vCurveParam(2)
1234 vStart = startp
1235
1236 endp(0) = vCurveParam(3)
1237 endp(1) = vCurveParam(4)
1238 endp(2) = vCurveParam(5)
1239 vEnd = endp
1240
1241 Dim retval As Object
1242
1243 retval = swCurve.ConvertLineToBcurve(vStart, vEnd)
1244
1245 ' on suppose que la droite est toujours transformée en spline non-rationelle de dimension 3 et d'ordre 2
1246 Dim knots(3) As Double
1247 Dim ctrlPoints(5) As Double
1248
1249 knots(0) = retval(2)
1250 knots(1) = retval(3)
1251 knots(2) = retval(4)
1252 knots(3) = retval(5)
1253
1254 ctrlPoints(0) = retval(6)
1255 ctrlPoints(1) = retval(7)
1256 ctrlPoints(2) = retval(8)
1257 ctrlPoints(3) = retval(9)
1258 ctrlPoints(4) = retval(10)
1259 ctrlPoints(5) = retval(11)
1260
1261 '3 - on créé une spline dans le modeleur
1262
1263
1264 Dim modeler As SldWorks.Modeler
1265 modeler = swApp.GetModeler
1266 Dim props As Object
1267 Dim dProps(1) As Double
1268 Dim vKnots As Object, vCtrlPoints As Object
1269
1270 dProps(0) = retval(0)
1271 dProps(1) = retval(1)
1272 props = dProps
1273 vKnots = knots
1274 vCtrlPoints = ctrlPoints
1275
1276 swCurve = modeler.CreateBsplineCurve(props, vKnots, vCtrlPoints)
1277 ' 4 - on a une spline, on peut utiliser la fonction IntersectCurve
1278 End If
1279
1280
1281 For i = 0 To 5
1282 nCurveBounds(i) = vCurveParam(i)
1283 Next i
1284
1285 vCurveBounds = nCurveBounds
1286 bRet = swSurf.IntersectCurve(swCurve, vCurveBounds, vPointArray, vTArray, vUVArray)
1287
1288 Dim Pts() As Double
1289 Dim PointsTemp() As Double = Nothing
1290 Dim j As Integer
1291
1292 Pts = vPointArray
1293
1294 If UBound(Pts) < 1 Then Return False
1295
1296 For i = 0 To UBound(Pts) - 1 Step 3
1297 ReDim Preserve PointsTemp(j + 2)
1298 PointsTemp(j) = Pts(i + 0)
1299 PointsTemp(j + 1) = Pts(i + 1)
1300 PointsTemp(j + 2) = Pts(i + 2)
1301 j += 3
1302 Next i
1303
1304 xyz = PointsTemp
1305 If xyz Is Nothing Then Return False
1306 If UBound(xyz) > 0 Then Return True
1307
1308
1309 End Function
1310
1311
1312
1313 Private Function DetectSommetArete(ByRef swsommet As SldWorks.Vertex, ByRef swArete As SldWorks.Edge, ByRef xyz() As Double) As Boolean
1314 Dim x As Double, y As Double, z As Double
1315 Dim vPoint As Object
1316 Dim vPoint2 As Object
1317 vPoint = swsommet.GetPoint
1318
1319 x = vPoint(0)
1320 y = vPoint(1)
1321 z = vPoint(2)
1322
1323 vPoint2 = swArete.GetClosestPointOn(x, y, z)
1324 If Math.Abs(vPoint2(0) - x) < Epsilon And Math.Abs(vPoint2(1) - y) < Epsilon And Math.Abs(vPoint2(2) - z) < Epsilon Then
1325 ReDim xyz(2)
1326 xyz(0) = x
1327 xyz(1) = y
1328 xyz(2) = z
1329 DetectSommetArete = True
1330 End If
1331
1332 End Function
1333
1334
1335 Private Function DetectSommetArete(ByRef x As Double, ByRef y As Double, ByRef z As Double, ByRef swArete As SldWorks.Edge) As Byte
1336 Dim vPoint As Object
1337 Dim vPoint2 As Object
1338
1339 vPoint2 = swArete.GetClosestPointOn(x, y, z)
1340 If Math.Abs(vPoint2(0) - x) < Epsilon And Math.Abs(vPoint2(1) - y) < Epsilon And Math.Abs(vPoint2(2) - z) < Epsilon Then
1341 DetectSommetArete = 1
1342
1343 ' maintenant on cherche à savoir si ca touche au premier sommet de l'arrête.
1344 vPoint = swArete.GetCurveParams2()
1345
1346 If Math.Abs(vPoint(0) - x) < Epsilon And Math.Abs(vPoint(1) - y) < Epsilon And Math.Abs(vPoint(2) - z) < Epsilon Then DetectSommetArete = 2
1347 If Math.Abs(vPoint(3) - x) < Epsilon And Math.Abs(vPoint(4) - y) < Epsilon And Math.Abs(vPoint(5) - z) < Epsilon Then DetectSommetArete = 2
1348
1349 End If
1350
1351 End Function
1352
1353 Private Function DetectSommetArete(ByRef swArete2som As SldWorks.Edge, ByRef swArete As SldWorks.Edge, ByRef xyz() As Double, Optional ByRef ret As Byte = 0) As Boolean
1354 ' ret: 1 = sur premier sommet, 2 = sur dernier sommet
1355 Dim x As Double, y As Double, z As Double
1356 Dim vPoint As Object
1357 Dim vPoint2 As Object
1358 Dim swSommet As SldWorks.Vertex
1359
1360 swSommet = swArete2som.GetStartVertex
1361 If IsNothing(swSommet) Then Exit Function ' on a un cercle...
1362
1363
1364 vPoint = swSommet.GetPoint
1365
1366 x = vPoint(0)
1367 y = vPoint(1)
1368 z = vPoint(2)
1369
1370 vPoint2 = swArete.GetClosestPointOn(x, y, z)
1371 If Math.Abs(vPoint2(0) - x) < Epsilon And Math.Abs(vPoint2(1) - y) < Epsilon And Math.Abs(vPoint2(2) - z) < Epsilon Then
1372 ReDim xyz(2)
1373 xyz(0) = x
1374 xyz(1) = y
1375 xyz(2) = z
1376 DetectSommetArete = True
1377 ret += 1
1378 End If
1379
1380 swSommet = swArete2som.GetEndVertex
1381 vPoint = swSommet.GetPoint
1382
1383 x = vPoint(0)
1384 y = vPoint(1)
1385 z = vPoint(2)
1386
1387 vPoint2 = swArete.GetClosestPointOn(x, y, z)
1388 If Math.Abs(vPoint2(0) - x) < Epsilon And Math.Abs(vPoint2(1) - y) < Epsilon And Math.Abs(vPoint2(2) - z) < Epsilon Then
1389 ReDim xyz(2)
1390 xyz(0) = x
1391 xyz(1) = y
1392 xyz(2) = z
1393 DetectSommetArete = True
1394 ret += 2
1395 End If
1396
1397
1398 End Function
1399
1400 Private Sub Memoriser3iemePoint()
1401 Dim poutre As SlyAretePoutre
1402 Dim attr As SldWorks.Attribute
1403 Dim p As SldWorks.Parameter
1404 Dim swEnt As SldWorks.Entity
1405
1406
1407
1408 For Each poutre In Commun.lst_AretePoutre
1409 Dim xyz() As Double
1410 Dim nom As String = Nothing
1411
1412 If Not poutre.IsFaceDeSection Then
1413 xyz = poutre.GetPoint3(nom)
1414
1415 poutre.X3 = xyz(0)
1416 poutre.Y3 = xyz(1)
1417 poutre.Z3 = xyz(2)
1418
1419 swEnt = poutre.swArete
1420
1421 attr = swEnt.FindAttribute(Intersections.DefAttrRCP1, 0)
1422 p = attr.GetParameter("N3")
1423
1424 p = attr.GetParameter("X3")
1425 p.SetDoubleValue2(poutre.X3, 2, "")
1426
1427 p = attr.GetParameter("Y3")
1428 p.SetDoubleValue2(poutre.Y3, 2, "")
1429
1430 p = attr.GetParameter("Z3")
1431 p.SetDoubleValue2(poutre.Z3, 2, "")
1432 End If
1433 Next poutre
1434
1435 End Sub
1436
1437
1438
1439 Private Sub CouperPoutres()
1440
1441 ' procédure qui trouve les intersections entre les poutres et qui les coupe.
1442 ' à la fin on a plus d'intersections entre les poutres (ailleur qu'un sommet)
1443
1444 Dim swArete1 As SldWorks.Edge
1445 Dim swArete2 As SldWorks.Edge
1446 Dim SlyArete1 As SlyAretePoutre
1447 Dim SlyArete2 As SlyAretePoutre
1448
1449 Dim xyz() As Double = Nothing
1450 Dim pt As New InterPoutrePoutre
1451 'Dim lst_pts As New Collection
1452 Dim i As Long
1453
1454 Dim a1 As Integer
1455 Dim a2 As Integer
1456
1457 Try
1458 For a1 = 0 To lst_AretePoutre.Count - 1
1459 SlyArete1 = lst_AretePoutre.Item(a1)
1460 swArete1 = SlyArete1.swArete
1461
1462 If Not a1 = lst_AretePoutre.Count - 1 Then
1463 For a2 = a1 + 1 To lst_AretePoutre.Count - 1
1464 SlyArete2 = lst_AretePoutre.Item(a2)
1465 swArete2 = SlyArete2.swArete
1466
1467 If DetectAreteArete(swArete1, swArete2, xyz) Then ' intersection courbe-courbe
1468 For i = 0 To CInt((UBound(xyz) + 1) / 4) Step 4 ' si y'a plus d'une intersection entre les 2 courbes...
1469
1470 Select Case isIntersect_milieu(swArete1, swArete2, xyz(i), xyz(i + 1), xyz(i + 2))
1471 Case 1 ' la première courbe est coupée
1472 pt = New InterPoutrePoutre
1473 pt.Arete = swArete1
1474 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1475 SlyArete1.AjouterPointAPAP(pt)
1476 pt = Nothing
1477 Case 2 ' la seconde courbe est coupée
1478 pt = New InterPoutrePoutre
1479 pt.Arete = swArete2
1480 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1481 SlyArete2.AjouterPointAPAP(pt)
1482 pt = Nothing
1483 Case 3 ' les doux poutres sont coupées
1484 pt = New InterPoutrePoutre
1485 pt.Arete = swArete1
1486 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1487 SlyArete1.AjouterPointAPAP(pt)
1488 pt = Nothing
1489 pt = New InterPoutrePoutre
1490 pt.Arete = swArete2
1491 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1492 SlyArete2.AjouterPointAPAP(pt)
1493 pt = Nothing
1494 End Select
1495 Next i
1496 End If
1497
1498 Next a2
1499 End If
1500
1501 Dim SlyArete3 As SlyAreteCoque
1502 For a2 = 0 To lst_AreteCoque.Count - 1
1503 SlyArete3 = lst_AreteCoque.Item(a2)
1504 swArete2 = SlyArete3.swArete
1505
1506 If DetectAreteArete(swArete1, swArete2, xyz) Then ' intersection courbe-courbe
1507 For i = 0 To CInt((UBound(xyz) + 1) / 4) Step 4 ' si y'a plus d'une intersection entre les 2 courbes...
1508
1509 Select Case isIntersect_milieu(swArete1, swArete2, xyz(i), xyz(i + 1), xyz(i + 2))
1510 Case 1 ' la première courbe est coupée
1511 pt = New InterPoutrePoutre
1512 pt.Arete = swArete1
1513 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1514 SlyArete1.AjouterPointAPAP(pt)
1515 pt = Nothing
1516 ' seul la coque est coupée, elle sera découpée anyway.
1517 Case 3 ' les doux poutres sont coupées, mais on note juste la deuxième
1518 pt = New InterPoutrePoutre
1519 pt.Arete = swArete1
1520 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1521 SlyArete1.AjouterPointAPAP(pt)
1522 pt = Nothing
1523 End Select
1524 Next i
1525 End If
1526 Next a2
1527
1528 Dim slyarete4 As SlyAreteVol
1529 For a2 = 0 To lst_AreteVolume.Count - 1
1530 slyarete4 = lst_AreteVolume.Item(a2)
1531 swArete2 = slyarete4.swArete
1532
1533 If DetectAreteArete(swArete1, swArete2, xyz) Then ' intersection courbe-courbe
1534 For i = 0 To CInt((UBound(xyz) + 1) / 4) Step 4 ' si y'a plus d'une intersection entre les 2 courbes...
1535
1536 Select Case isIntersect_milieu(swArete1, swArete2, xyz(i), xyz(i + 1), xyz(i + 2))
1537 Case 1 ' la première courbe est coupée
1538 pt = New InterPoutrePoutre
1539 pt.Arete = swArete1
1540 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1541 SlyArete1.AjouterPointAPAP(pt)
1542 pt = Nothing
1543 Case 3 ' les doux poutres sont coupées, mais on note juste la deuxième
1544 pt = New InterPoutrePoutre
1545 pt.Arete = swArete1
1546 pt.x = xyz(i) : pt.y = xyz(i + 1) : pt.z = xyz(i + 2)
1547 SlyArete1.AjouterPointAPAP(pt)
1548 pt = Nothing
1549 End Select
1550 Next i
1551 End If
1552 Next a2
1553
1554
1555
1556 Next a1
1557 pt = Nothing
1558
1559 Catch
1560 MsgBox(" La première boucle n'a pas marchée")
1561 End Try
1562
1563
1564 Dim count As Long = 0, count2 As Long = 0
1565 Try
1566
1567 'toutes les poutres ont des points où elles doivent être coupées
1568 ' il suffit de couper.
1569 ' en réalité on suppress et on créé 2 ou plus courbes par dessus.
1570 Dim attr As sldworks.Attribute
1571 Dim swEnt As sldworks.Entity
1572
1573 For Each SlyArete1 In lst_AretePoutre
1574 If SlyArete1.lst_PtsInterAPAP.Count > 0 Then ' on coupe
1575 '1 - ordonner les points, de Tmin à Tmax et inclure les 2 extrémités de la poutre
1576
1577 count += 1
1578 ' si c'est une droite
1579 If SlyArete1.IsLine Then
1580 Dim Pts(,) As Double
1581 Dim swSketch As sldworks.Sketch
1582 ReDim Pts(3, SlyArete1.lst_PtsInterAPAP.Count + 1)
1583
1584 SlyArete1.GetStartPoint(Pts(0, 0), Pts(1, 0), Pts(2, 0)) ' le premier point
1585 Pts(3, 0) = SlyArete1.GetT(Pts(0, 0), Pts(1, 0), Pts(2, 0))
1586
1587 For i = 1 To SlyArete1.lst_PtsInterAPAP.Count
1588 Pts(0, i) = SlyArete1.lst_PtsInterAPAP.Item(i).x
1589 Pts(1, i) = SlyArete1.lst_PtsInterAPAP.Item(i).y
1590 Pts(2, i) = SlyArete1.lst_PtsInterAPAP.Item(i).z
1591 Pts(3, i) = SlyArete1.GetT(Pts(0, i), Pts(1, i), Pts(2, i))
1592 Next i
1593
1594 Dim max As Integer = SlyArete1.lst_PtsInterAPAP.Count + 1
1595 SlyArete1.GetEndPoint(Pts(0, max), Pts(1, max), Pts(2, max)) ' le dernier point
1596 Pts(3, max) = SlyArete1.GetT(Pts(0, max), Pts(1, max), Pts(2, max))
1597
1598 ' faut ordonner les points selon T...
1599 Dim j As Integer
1600 Dim T1 As Double, T2 As Double, T3 As Double, T0 As Double
1601 For i = 0 To max - 2
1602 For j = 0 To max - i - 1
1603 If Pts(3, j) > Pts(3, j + 1) Then
1604 T0 = Pts(0, j) : T1 = Pts(1, j) : T2 = Pts(2, j) : T3 = Pts(3, j)
1605 Pts(0, j) = Pts(0, j + 1) : Pts(1, j) = Pts(1, j + 1) : Pts(2, j) = Pts(2, j + 1) : Pts(3, j) = Pts(3, j + 1)
1606 Pts(0, j + 1) = T0 : Pts(1, j + 1) = T1 : Pts(2, j + 1) = T2 : Pts(3, j + 1) = T3
1607 End If
1608 Next j
1609 Next i
1610
1611
1612 For i = 0 To UBound(Pts, 2) - 1
1613 swModel.Insert3DSketch2(False)
1614 swModel.CreateLine2(Pts(0, i), Pts(1, i), Pts(2, i), Pts(0, i + 1), Pts(1, i + 1), Pts(2, i + 1)) ' et pour chaque segment
1615 swSketch = swModel.GetActiveSketch2
1616 swModel.Insert3DSketch2(False)
1617
1618 swEnt = swSketch : swEnt.Select2(False, 1) ' doit avoir un mark de 1
1619 swModel.InsertCompositeCurve()
1620 Try
1621 count2 += 1
1622 UpdateAttributs(SlyArete1, i) 'ajouter les attributs de la vieille poutre sur la nouvelle
1623 Catch
1624 MsgBox("UpdateAttribut n'a pas marché au compte # " & count2)
1625 End Try
1626 Next i
1627
1628
1629 Else ' If SlyArete1.IsCircle Then ' si c'est un cercle
1630
1631 Dim Pts(,) As Double
1632 Dim swSketch As sldworks.Sketch
1633 ReDim Pts(3, SlyArete1.lst_PtsInterAPAP.Count + 1)
1634
1635 SlyArete1.GetStartPoint(Pts(0, 0), Pts(1, 0), Pts(2, 0)) ' le premier point
1636 Pts(3, 0) = SlyArete1.GetT(Pts(0, 0), Pts(1, 0), Pts(2, 0))
1637
1638 For i = 1 To SlyArete1.lst_PtsInterAPAP.Count
1639 Pts(0, i) = SlyArete1.lst_PtsInterAPAP.Item(i).x
1640 Pts(1, i) = SlyArete1.lst_PtsInterAPAP.Item(i).y
1641 Pts(2, i) = SlyArete1.lst_PtsInterAPAP.Item(i).z
1642 Pts(3, i) = SlyArete1.GetT(Pts(0, i), Pts(1, i), Pts(2, i))
1643 Next i
1644
1645 Dim max As Integer = SlyArete1.lst_PtsInterAPAP.Count + 1
1646 SlyArete1.GetEndPoint(Pts(0, max), Pts(1, max), Pts(2, max)) ' le dernier point
1647 Pts(3, max) = SlyArete1.GetT(Pts(0, max), Pts(1, max), Pts(2, max))
1648
1649 ' faut ordonner les points selon T...
1650 Dim j As Integer
1651 Dim T1 As Double, T2 As Double, T3 As Double, T0 As Double
1652 For i = 0 To max - 2
1653 For j = 0 To max - i - 1
1654 If Pts(3, j) > Pts(3, j + 1) Then
1655 T0 = Pts(0, j) : T1 = Pts(1, j) : T2 = Pts(2, j) : T3 = Pts(3, j)
1656 Pts(0, j) = Pts(0, j + 1) : Pts(1, j) = Pts(1, j + 1) : Pts(2, j) = Pts(2, j + 1) : Pts(3, j) = Pts(3, j + 1)
1657 Pts(0, j + 1) = T0 : Pts(1, j + 1) = T1 : Pts(2, j + 1) = T2 : Pts(3, j + 1) = T3
1658 End If
1659 Next j
1660 Next i
1661
1662 Dim skSeg As sldworks.SketchSegment
1663 Dim x As Double, y As Double, z As Double
1664 Dim vretval As Object
1665 Dim useEdge As sldworks.SketchSegment
1666 Dim m As Integer
1667
1668
1669 For i = 0 To UBound(Pts, 2) - 1
1670 swModel.Insert3DSketch2(False)
1671 ' sélectionner la edge originale
1672 swEnt = SlyArete1.swArete
1673 swEnt.Select4(False, Nothing)
1674 swModel.SketchUseEdge2(False)
1675 swSketch = swModel.GetActiveSketch2()
1676
1677 ' on créé 2 lignes de construction et on pick de chaque coté... mais on ne le fait pas si on est au premier ou au dernier segment. là on fait juste un pick.
1678 If i <> 0 Then ' premier pick, élimine ce qui est avant.
1679 skSeg = swModel.CreateLine2(Pts(0, i), Pts(1, i), Pts(2, i), 0.01, 0.01, 0.01) 'pts(0, i - 1) + 10000000 * Epsilon, pts(1, i - 1) + 100000 * Epsilon, pts(2, i - 1) + 100000 * Epsilon)
1680 skSeg.ConstructionGeometry = True ' ligne de construction
1681 swModel.ClearSelection2(True)
1682 ' x et y doit être sélectionné sur un point avec un T inférieur au point d'intersection
1683 SlyArete1.Evaluer((Pts(3, i - 1) + Pts(3, i)) / 2, x, y, z)
1684 vretval = swSketch.GetSketchSegments
1685 useEdge = vretval(0) : m = 0
1686 Do Until useEdge.ConstructionGeometry = False
1687 m += 1
1688 useEdge = vretval(m)
1689 Loop
1690 useEdge.Select4(False, Nothing)
1691 swModel.SketchTrim(1, 0, x, y) ' option = 1 pour trim, selEnd est pas utilisé ?, puis un point x et Y pour sélectionner. et y'a pas de Z????? c'est un sketch3D!!!!!
1692 skSeg = swModel.CreateLine2(0, 0, 0, x, y, 0)
1693 skSeg.ConstructionGeometry = True
1694 End If
1695
1696 If i <> UBound(Pts, 2) - 1 Then 'Second(pick)
1697 skSeg = swModel.CreateLine2(Pts(0, i + 1), Pts(1, i + 1), Pts(2, i + 1), 0.05, 0, 0.01) 'pts(0, i + 1) + 10000000 * Epsilon, pts(1, i + 1) + 1000000 * Epsilon, pts(2, i + 1) + 100000 * Epsilon)
1698 skSeg.ConstructionGeometry = True ' ligne de construction
1699 swModel.ClearSelection2(True)
1700
1701 ' x et y doit être sélectionné sur un point avec un T inférieur au point d'intersection
1702 SlyArete1.Evaluer((Pts(3, i + 1) + Pts(3, i + 2)) / 2, x, y, z)
1703 vretval = swSketch.GetSketchSegments
1704 useEdge = vretval(0) : m = 0
1705 Do Until useEdge.ConstructionGeometry = False
1706 m += 1
1707 useEdge = vretval(m)
1708 Loop
1709
1710 useEdge.Select4(False, Nothing)
1711 swModel.SketchTrim(1, 0, x, y) ' option = 1 pour trim, selEnd est pas utilisé ?, puis un point x et Y pour sélectionner. et y'a pas de Z????? c'est un sketch3D!!!!!
1712 skSeg = swModel.CreateLine2(0, 0.02, 0, x, y, 0)
1713 skSeg.ConstructionGeometry = True
1714 End If
1715
1716 swModel.Insert3DSketch2(False)
1717 swEnt = swSketch : swEnt.Select2(False, 1) ' doit avoir un mark de 1
1718 swModel.InsertCompositeCurve()
1719 UpdateAttributs(SlyArete1, i)
1720 Next i
1721
1722 End If
1723
1724 ' tagger la vieille poutre pour ne pas la reprendre dans magic
1725 'Pour ça on ajoute un attribut pour ignorer...
1726 Dim nom As String
1727 Dim no As Integer
1728 Dim arete As sldworks.Edge
1729
1730 arete = SlyArete1.swArete
1731 swEnt = arete
1732 nom = "Ignorer" & SlyArete1.nom & "_" & CStr(no)
1733 attr = swEnt.FindAttribute(Intersections.DefAttrRCP1, 0)
1734 'attr = DefAttrRCP1.CreateInstance5(swModel, arete, nom, 0, 2) ' une deuxième instance du RCPoutre...
1735 If attr Is Nothing Then
1736 Commun.ColorerAretes()
1737 swEnt = SlyArete1.swArete
1738 attr = swEnt.FindAttribute(Intersections.DefAttrRCP1, 0)
1739 End If
1740
1741 Dim p As sldworks.Parameter
1742 p = attr.GetParameter("D1")
1743 p.SetDoubleValue(-9)
1744 p = attr.GetParameter("D2")
1745 p.SetDoubleValue(-9)
1746 p = attr.GetParameter("D3")
1747 p.SetDoubleValue(-9)
1748 p = attr.GetParameter("D4")
1749 p.SetDoubleValue(-9)
1750
1751 If attr Is Nothing Then MsgBox("Pas marché")
1752
1753
1754 End If
1755 Next SlyArete1
1756 Catch
1757 MsgBox("La seconde boucle n'a pas marchée Compte: " & count)
1758 End Try
1759
1760 End Sub
1761
1762
1763 Private Sub UpdateAttributs(ByRef slyarete1 As SlyAretePoutre, ByVal i As Integer)
1764 Dim newArete As sldworks.Edge
1765 Dim refcurve As sldworks.ReferenceCurve
1766 Dim attr As sldworks.Attribute = Nothing
1767 Dim swfeat As sldworks.Feature
1768 swModel.EditRebuild3()
1769 swfeat = swModel.FeatureByPositionReverse(0)
1770
1771 Debug.Print(swfeat.Name & "<-- Nom Typename--> " & swfeat.GetTypeName)
1772
1773 refcurve = swfeat.GetSpecificFeature2()
1774 newArete = refcurve.GetFirstSegment()
1775
1776 Dim ParamM As sldworks.Parameter
1777 Dim ParamS As sldworks.Parameter
1778 Dim ParamI1 As sldworks.Parameter
1779 Dim ParamI2 As sldworks.Parameter
1780 Dim ParamD1 As sldworks.Parameter
1781 Dim ParamD2 As sldworks.Parameter
1782 Dim ParamD3 As sldworks.Parameter
1783 Dim ParamD4 As sldworks.Parameter
1784 Dim ParamD5 As sldworks.Parameter
1785 Dim ParamD6 As sldworks.Parameter
1786 Dim ParamAs As sldworks.Parameter
1787 Dim ParamN3 As sldworks.Parameter
1788
1789 Do While attr Is Nothing
1790 attr = Intersections.DefAttrRCP1.CreateInstance5(swModel, newArete, "Nouveau" & i & slyarete1.nom, 0, 2)
1791 i += 1
1792 Loop
1793
1794 ParamM = attr.GetParameter("M")
1795 ParamS = attr.GetParameter("S")
1796 ParamI1 = attr.GetParameter("I1")
1797 ParamI2 = attr.GetParameter("I2")
1798 ParamD1 = attr.GetParameter("D1")
1799 ParamD2 = attr.GetParameter("D2")
1800 ParamD3 = attr.GetParameter("D3")
1801 ParamD4 = attr.GetParameter("D4")
1802 ParamD5 = attr.GetParameter("D5")
1803 ParamD6 = attr.GetParameter("D6")
1804 ParamAs = attr.GetParameter("As")
1805
1806 ParamM.SetStringValue2(slyarete1.GetM, 2, "") ' swAllConfiguration = 2
1807 ParamS.SetStringValue2(slyarete1.GetSection, 2, "")
1808 ParamI1.SetDoubleValue2(slyarete1.GetInertieXX, 2, "")
1809 ParamI2.SetDoubleValue2(slyarete1.GetInertieYY, 2, "")
1810 ParamD1.SetDoubleValue2(slyarete1.GetD1, 2, "")
1811 ParamD2.SetDoubleValue2(slyarete1.GetD2, 2, "")
1812 ParamD3.SetDoubleValue2(slyarete1.GetD3, 2, "")
1813 ParamD4.SetDoubleValue2(slyarete1.GetD4, 2, "")
1814 ParamD5.SetDoubleValue2(slyarete1.GetD5, 2, "")
1815 ParamD6.SetDoubleValue2(slyarete1.GetD6, 2, "")
1816 ParamAs.SetDoubleValue2(slyarete1.GetAireSection, 2, "")
1817
1818 Dim p As sldworks.Parameter
1819 p = attr.GetParameter("N3")
1820 p.SetStringValue(slyarete1.GetN3)
1821 p = attr.GetParameter("X3")
1822 p.SetDoubleValue2(slyarete1.X3, 2, "")
1823 p = attr.GetParameter("Y3")
1824 p.SetDoubleValue2(slyarete1.Y3, 2, "")
1825 p = attr.GetParameter("Z3")
1826 p.SetDoubleValue2(slyarete1.Z3, 2, "")
1827
1828 ' Commun.GererDossiers("Poutres", "Nouveau" & i & slyarete1.nom)
1829
1830 End Sub
1831
1832
1833
1834
1835 ''' <summary>
1836 ''' sub qui gère la détection des intersections entre les coques et les volumes.
1837 ''' </summary>
1838 ''' <remarks></remarks>
1839 Private Sub DetectionCoqueVolume()
1840
1841 ' détection de coque-coque
1842 Dim Face1 As SlyFaceVolume
1843 Dim coque2 As SlyFaceCoque
1844 Dim sketch As SldWorks.Sketch = Nothing
1845 Dim interFF As InterCoqueVolume
1846
1847 For Each Face1 In Commun.lst_FaceVolume
1848 For Each coque2 In lst_FaceCoque
1849
1850 If DetectFaceFace(coque2, Face1, True, sketch) Then
1851 ' création de l'instance de interFace-face entre coque et volume
1852
1853 Dim vSeg As Object = sketch.GetSketchSegments()
1854 If vSeg Is Nothing Then
1855 DetectFaceFace(coque2, Face1, True, sketch)
1856 vSeg = sketch.GetSketchSegments()
1857 If vSeg Is Nothing Then MsgBox("Problème") : Err.Raise(555)
1858 End If
1859
1860
1861
1862 interFF = New InterCoqueVolume
1863 interFF.sFaceVolume = Face1
1864 interFF.sFaceCoque = coque2
1865 If coque2.PossedeFaceDeSection = True Then
1866 interFF.FaceDeSection = True
1867 Verifier_Coque_Section(interFF)
1868 Else
1869 interFF.FaceDeSection = False
1870 End If
1871 interFF.sketch = sketch
1872 coque2.lst_InterCoqueVolume.Add(interFF)
1873 End If
1874
1875 Next coque2
1876 Next Face1
1877
1878
1879
1880
1881 End Sub
1882
1883 ''' <summary>
1884 ''' Sub qui fait les 6 vérifications pour le type d'intersection où la coque est partiellement dessinée en 3D.
1885 ''' En profite également pour remettre à jour la proriété de l'épaisseur de la coque
1886 ''' </summary>
1887 ''' <param name="interFF">L'intersection</param>
1888 ''' <remarks>On fait au total 6 vérifications</remarks>
1889 Private Sub Verifier_Coque_Section(ByRef interFF As InterCoqueVolume)
1890 Dim sFaceCoque As SlyFaceCoque
1891 Dim sFaceVol As SlyFaceVolume
1892 Dim swFace1 As SldWorks.Face2
1893 Dim swent As SldWorks.Entity
1894
1895 sFaceCoque = interFF.sFaceCoque
1896 sFaceVol = interFF.sFaceVolume
1897
1898 ' 1 - vérifier que la face du volume est plane
1899 If Not sFaceVol.estPlan Then
1900 Err.Raise(513, "Verifier_Coque_Section", "La face représentant la section de la coque n'est pas plane...")
1901 End If
1902
1903 ' 1.5 - La face du volume a 4 courbes, 2 petites de même longueur et 2 longues
1904 ' 1.6 ou qu'elle est une courbe fermée avec 2 loop d'une seule arète chaque.
1905 Dim vEdges As Object
1906 Dim Aretes() As SldWorks.Edge
1907 Dim longueur(3) As Double
1908 Dim i As Integer
1909 Dim a As SldWorks.Edge
1910 ReDim Aretes(0)
1911
1912 swFace1 = sFaceVol.SwFace
1913
1914 vEdges = swFace1.GetEdges()
1915 For Each a In vEdges
1916 ReDim Preserve Aretes(i)
1917 Aretes(i) = a
1918 i += 1
1919 Next
1920
1921 If UBound(Aretes) = 3 Then
1922 For i = 0 To 3
1923 longueur(i) = Commun.GetLongueurArete(Aretes(i))
1924 Next i
1925 longueur = Ordonner(longueur, Aretes)
1926 If Not Math.Abs(longueur(0) - longueur(1)) < Epsilon Then
1927 swent = swFace1 : swent.Select2(False, 0)
1928 Err.Raise(514, "Verifier_Coque_Section", "La face du volume représentant la coque n'a pas 2 petites arètes de la même longueur, ce n'est pas normal. La face a problème a été sélectionée")
1929 End If
1930
1931 ElseIf UBound(Aretes) = 1 Then ' la coque représente un cylindre (ou un autre truc fermé)
1932 If Not swFace1.GetLoopCount = 2 Then
1933 swent = swFace1 : swent.Select2(False, 0)
1934 Err.Raise(514, "Verifier_Coque_Section", "La face du volume représentant la coque n'a pas 2 ou 4 arêtes ou n'est pas correcte... La face a problème a été sélectionée")
1935 End If
1936 Else
1937 swent = swFace1 : swent.Select2(False, 0)
1938 Err.Raise(514, "Verifier_Coque_Section", "La face du volume représentant la coque n'a pas 2 ou 4 arêtes. La face a problème a été sélectionée")
1939 End If
1940
1941 ' 2 - Vérifier que la ligne est plane, mais ça je ne sais pas comment
1942
1943 ' 3 - Perpendiculaire
1944 ' ok, on va chercher le midpoint de la ligne et on demande la normale à cette position des 2 faces. Puis on demande(l) 'angle entre les 2 normales...
1945
1946 Dim swArete As SldWorks.Edge
1947 Dim vmid As Object
1948 Dim mid() As Double = Nothing
1949 Dim T As Double
1950 Dim u() As Double, v() As Double
1951 Dim angle As Double
1952
1953 If interFF.AreteCoque Is Nothing Then interFF.QuelleAreteCoqueToucheVolume() : Dim effacer As New SuperArete(interFF.AreteCoque, True) ': effacer.Colorer(2, 0.7, 0, 0.7)
1954 swArete = interFF.AreteCoque
1955 T = Commun.GetTMilieu(swArete)
1956 vmid = swArete.Evaluate(T)
1957 mid = vmid
1958
1959 u = sFaceVol.GetNormale(mid(0), mid(1), mid(2))
1960 v = sFaceCoque.GetNormale(mid(0), mid(1), mid(2))
1961
1962 angle = Outils_Math.Angle2Vecteurs(u, v)
1963
1964 If Not Math.Abs(angle - Pi / 2) < (Epsilon * 10) Then
1965 sFaceVol.Selectionner(, False)
1966 sFaceCoque.Selectionner(, True)
1967 Err.Raise(515, "Verifier_Coque_Section", "La face de la coque n'est pas perpendiculaire à la face représentant sa section. Les faces fautives ont été sélectionées.")
1968 End If
1969
1970 ' 4 - vérifier que les 2 petites arètes sont coupées au milieu
1971
1972
1973 ' maintenant on update l'attribut de la coque, par chance, j'ai les coordonnées du point milieu...
1974 Dim epaisseur As Double
1975 Dim distance1 As Double, distance2 As Double
1976 Dim point1(2) As Double, point2(2) As Double
1977 Dim p As Object = Nothing, p2 As Object = Nothing
1978
1979 If UBound(Aretes) = 3 Then
1980 p = Aretes(2).GetClosestPointOn(mid(0), mid(1), mid(2))
1981 point1(0) = p(0) : point1(1) = p(1) : point1(2) = p(2)
1982 distance1 = Math.Sqrt((point1(0) - mid(0)) ^ 2 + (point1(1) - mid(1)) ^ 2 + (point1(2) - mid(2)) ^ 2)
1983
1984 p = Aretes(3).GetClosestPointOn(mid(0), mid(1), mid(2))
1985 point2(0) = p(0) : point2(1) = p(1) : point2(2) = p(2)
1986 distance2 = Math.Sqrt((point2(0) - mid(0)) ^ 2 + (point2(1) - mid(1)) ^ 2 + (point2(2) - mid(2)) ^ 2)
1987
1988 If Not Math.Abs(distance1 - distance2) < Epsilon Then
1989 Err.Raise(516, "Verifier_Coque_Section", "La distance n'est pas la même de chaque coté de la coque")
1990 Else
1991 epaisseur = distance1 * 2
1992 End If
1993
1994 ElseIf UBound(Aretes) = 1 Then ' on a des cercles
1995 epaisseur = swModel.ClosestDistance(Aretes(0), Aretes(1), p, p2)
1996 If epaisseur <= 0 Then MsgBox("Il y a un problème ici...")
1997 Else
1998 MsgBox("On ne doit jamias passer ici en principe")
1999 End If
2000
2001 sFaceCoque.SetAttributDeCoque(epaisseur)
2002
2003 End Sub
2004
2005 ''' <summary>
2006 ''' sub qui découpe une face en fonction des paramètres qu'on lui passe.
2007 ''' </summary>
2008 ''' <remarks></remarks>
2009 Private Sub DécouperCoqueVolume()
2010
2011 ' Algo:
2012 ' Pour chaque coque
2013 ' Si on doit couper la coque, alors on la coupe
2014 ' On découpe la face du volume
2015 ' ON identifie les faces internes
2016
2017
2018 Dim coque1 As SlyFaceCoque
2019 Dim interFF As InterCoqueVolume
2020
2021 ' 1 - Pour toutes les coques
2022 Dim lst_face As New Collections.Generic.List(Of SlyFaceVolume)
2023
2024 For Each coque1 In Commun.lst_FaceCoque
2025
2026 For Each interFF In coque1.lst_InterCoqueVolume
2027
2028 'If interFF.Face_A_Plat Then
2029 ' If Not lst_face.Contains(interFF.sFaceVolume) Then
2030 ' lst_face.Add(interFF.sFaceVolume)
2031 ' interFF.DécouperFace_A_Plat()
2032 ' End If
2033
2034
2035 If interFF.FaceDeSection Then
2036 CoupeCoque1(interFF)
2037 If Not Intersections.MultiDecoupageCoques Then interFF.MarquerFacesInternes()
2038 Else
2039
2040 If interFF.DoitCouperCoque Then
2041 interFF.DecouperCoque()
2042 interFF.QuelleAreteCoqueToucheVolume()
2043 End If
2044 interFF.DécouperVolume()
2045 If Not Intersections.MultiDecoupageCoques Then interFF.MarquerFacesInternes() ' étape 6
2046
2047 End If
2048 Next interFF
2049 Next coque1
2050
2051
2052 End Sub
2053
2054
2055
2056 ''' <summary>
2057 ''' Lorsque la coque est modélisée en partie par un morceau de volume. Dessine et coupe.
2058 ''' </summary>
2059 ''' <param name="int">L'interFaceFace</param>
2060 ''' <remarks></remarks>
2061 Private Sub CoupeCoque1(ByRef int As InterCoqueVolume)
2062 Dim sVol As SlyFaceVolume
2063 Dim swFace As SldWorks.Face2
2064 Dim swent As SldWorks.Entity
2065 Dim sketch As SldWorks.Sketch
2066 Dim vEdges As Object
2067 Dim swArete As SldWorks.Edge
2068 Dim aretes() As SldWorks.Edge = Nothing
2069 Dim i As Integer
2070
2071 ' a - prendre la face du volume
2072 sVol = int.sFaceVolume
2073 swFace = sVol.SwFace
2074 sVol.Selectionner(0, False)
2075
2076 '' b - lui mettre une esquisse
2077 'swModel.InsertSketch2(True)
2078
2079 '' c - convertir l'esquisse déjà créée
2080 'sketch = int.sketch
2081 'swent = sketch
2082 'swent.Select2(False, 0)
2083
2084 'swModel.SketchUseEdge2(False)
2085
2086 '' si la face est carrée
2087
2088 'If swFace.GetEdgeCount = 4 Then
2089 ' ' d - ajouter des lignes pour compléter l'esquisse
2090 ' Dim longueur(3) As Double
2091
2092
2093 ' Dim vLine As Object
2094 ' Dim line1 As SldWorks.SketchLine, line2 As SldWorks.SketchLine
2095 ' Dim P1 As SldWorks.SketchPoint, P2 As SldWorks.SketchPoint, P3 As SldWorks.SketchPoint, P4 As SldWorks.SketchPoint
2096 ' Dim skSeg As SldWorks.SketchSegment
2097 ' vEdges = swFace.GetEdges()
2098 ' For Each swArete In vEdges
2099 ' ReDim Preserve aretes(i)
2100 ' aretes(i) = swArete
2101 ' i += 1
2102 ' Next
2103 ' For i = 0 To 3
2104 ' longueur(i) = Commun.GetLongueurArete(vEdges(i))
2105 ' Next i
2106 ' longueur = Ordonner(longueur, aretes)
2107
2108 ' swent = aretes(3) : swent.Select2(False, 0) ' on prend la plus grande arète
2109 ' swModel.SketchUseEdge2(False)
2110 ' sketch = swModel.GetActiveSketch()
2111 ' vLine = sketch.GetSketchSegments()
2112 ' skSeg = vLine(0) : line1 = skSeg
2113 ' skSeg = vLine(1) : line2 = skSeg
2114
2115 ' P1 = line1.GetStartPoint2()
2116 ' P2 = line1.GetEndPoint2()
2117 ' P3 = line2.GetStartPoint2()
2118 ' P4 = line2.GetEndPoint2()
2119
2120 ' If Distance(P1.X, P1.Y, P1.Z, P3.X, P3.Y, P3.Z) < Distance(P1.X, P1.Y, P1.Z, P4.X, P4.Y, P4.Z) Then ' ligne entre 1 et 3
2121 ' swModel.CreateLine2(P1.X, P1.Y, P1.Z, P3.X, P3.Y, P3.Z)
2122 ' swModel.CreateLine2(P2.X, P2.Y, P2.Z, P4.X, P4.Y, P4.Z)
2123 ' Else ' ligne entre 1 et 4 & 2 et 3
2124 ' swModel.CreateLine2(P1.X, P1.Y, P1.Z, P4.X, P4.Y, P4.Z)
2125 ' swModel.CreateLine2(P2.X, P2.Y, P2.Z, P3.X, P3.Y, P3.Z)
2126 ' End If
2127 'Else
2128 ' sketch = swModel.GetActiveSketch()
2129 'End If
2130 'swModel.InsertSketch2(True)
2131
2132
2133 '' e - splitter
2134 'swent = swFace : swent.Select2(False, 1)
2135 'swent = sketch : swent.Select2(True, 4)
2136 'swModel.InsertSplitLineProject(False, False)
2137
2138
2139 sVol.Selectionner(32, False) 'swPart.Extension.SelectByID2("", "FACE", 0.05746341258515, 0.007456177698316, 0.04437034503314, False, 16, Nothing, 0)
2140 int.sFaceCoque.Selectionner(16, True) 'swPart.Extension.SelectByID2("", "FACE", 0.03921396269902, -0.007016448377556, 0, True, 32, Nothing, 0)
2141 swPart.FeatureManager.InsertSplitLineIntersect(7)
2142
2143 ' f - mettre un FaceInterne sur les 2 faces résultantes.
2144 Dim swFeat As SldWorks.Feature
2145 Dim vFace As Object
2146 Dim swFace1 As SldWorks.Face2, swFace2 As SldWorks.Face2
2147 Dim attr As SldWorks.Attribute
2148 Dim nom As String
2149 Dim no As Long
2150 swFeat = swModel.FeatureByPositionReverse(0)
2151 vFace = swFeat.GetFaces
2152
2153 swFace1 = vFace(0)
2154 swFace2 = vFace(1)
2155
2156 sVol.AjouterFace(swFace1)
2157 sVol.AjouterFace(swFace2)
2158
2159 'Dim eFace As New SlyFaceVolume(swFace1, True)
2160 'eFace.MettreAttributFaceInterne(swFace1, , False)
2161
2162 'swent = swFace1
2163 'attr = swent.FindAttribute(Intersections.DefAttrFaceInterne, 0) ' si l'attribut existe déjà on pointe dessus.
2164 'nom = "FaceInterneCoque1"
2165 'If attr Is Nothing Then attr = Intersections.DefAttrFaceInterne.CreateInstance5(swModel, swFace1, nom, 0, 2) ' 0 = swThisconfig
2166
2167 'While attr Is Nothing
2168 ' no += 1
2169 ' nom = "FaceInterneCoque" & CStr(no)
2170 ' attr = Intersections.DefAttrFaceInterne.CreateInstance5(swModel, swFace1, nom, 0, 2)
2171 'End While
2172 'GererDossiers("FaceInternes", nom)
2173
2174 'swent = swFace2
2175 'attr = swent.FindAttribute(Intersections.DefAttrFaceInterne, 0) ' si l'attribut existe déjà on pointe dessus.
2176 'nom = "FaceInterneCoque1"
2177 'If attr Is Nothing Then attr = Intersections.DefAttrFaceInterne.CreateInstance5(swModel, swFace2, nom, 0, 2) ' 0 = swThisconfig
2178
2179 'While attr Is Nothing
2180 ' no += 1
2181 ' nom = "FaceInterneCoque" & CStr(no)
2182 ' attr = Intersections.DefAttrFaceInterne.CreateInstance5(swModel, swFace2, nom, 0, 2)
2183 'End While
2184 'GererDossiers("FaceInternes", nom)
2185
2186
2187 End Sub
2188
2189
2190 ''' <summary>
2191 ''' Détecte s'il y a une intersection entre une coque et une face d'un volume
2192 ''' </summary>
2193 ''' <param name="sFaceCoque"></param>
2194 ''' <param name="sFaceVolume"></param>
2195 ''' <param name="dessiner">Si oui, alors on dessine une ligne à l'intersection</param>
2196 ''' <param name="sketch">Si dessiner est vrai, alors ce sketch contient la ligne d'intersection</param>
2197 ''' <returns>Vrai s'il y a une intersection</returns>
2198 ''' <remarks></remarks>
2199 Private Function DetectFaceFace(ByRef sFaceCoque As SlyFaceCoque, ByRef sFaceVolume As SlyFaceVolume, Optional ByRef dessiner As Boolean = False, Optional ByRef sketch As SldWorks.Sketch = Nothing) As Boolean
2200 For Each swfc As SldWorks.Face2 In sFaceCoque.lst_Faces
2201 For Each swFV As SldWorks.Face2 In sFaceVolume.lst_Faces
2202 If DetectFaceFace(swfc, swFV, dessiner, sketch) Then Return True
2203 Next
2204 Next
2205 End Function
2206
2207
2208 ''' <summary>
2209 ''' Function qui retourne vrai ou faux si 2 FACES (pas surfaces) se touchent. La routine finit par appeler la sub dessinecourbe pour dessiner la courbe.
2210 ''' </summary>
2211 ''' <param name="face1">Première face</param>
2212 ''' <param name="face2">Seconde face</param>
2213 ''' <param name="dessiner">Si l'on veut dessiner une esquisse contenant la courbe</param>
2214 ''' <param name="Sketch">Si la précédente option est vrai, ce paramètre redonne l'esquisse qui contient la courbe (peut contenir plusieurs segments) d'intersection</param>
2215 ''' <returns>Vrai si les faces se touchent</returns>
2216 ''' <remarks>Si les 2 faces se touchent en un seul point alors ça retourne faux.</remarks>
2217 Private Function DetectFaceFace(ByRef face1 As SldWorks.Face2, ByRef face2 As SldWorks.Face2, Optional ByRef dessiner As Boolean = False, Optional ByRef Sketch As SldWorks.Sketch = Nothing) As Boolean
2218 'sub qui détecte si 2 faces se touchent et retourne vrai si c'est le cas.
2219 Dim Surface1 As sldworks.Surface
2220 Dim Surface2 As sldworks.Surface
2221 Dim curveArray As Object = Nothing
2222 Dim curve As sldworks.Curve
2223 Dim ret As Boolean
2224 Dim boundsArray As Object = Nothing
2225 Dim bounds() As Double
2226 Dim Point1(2) As Double
2227 Dim Point2(2) As Double
2228 Dim P1 As Object = Nothing, P2 As Object = Nothing
2229 Dim ClosestDist As Double
2230
2231 Surface1 = face1.GetSurface
2232 Surface2 = face2.GetSurface
2233
2234 ClosestDist = swModel.ClosestDistance(face1, face2, P1, P2)
2235 If ClosestDist > (Epsilon * 10) Then Return False
2236
2237 ' curvearray est un tableau de curves, boundsarray est un tableau de T des limites de la courbe
2238 ret = Surface1.IntersectSurface(Surface2, curveArray, boundsArray) ' si c'est une ligne, retourne une ligne infinie...
2239 ' il faut alors renvoyer vers le detectFaceArete()
2240 If Not ret Then Return False
2241 bounds = boundsArray
2242
2243 Try
2244 curve = curveArray(0)
2245 Catch
2246
2247 'MsgBox("On a une intersection où 2 faces sont sur la même surface...") ' en théorie...
2248 Return True ' ouch... pas certain.
2249 End Try
2250
2251
2252 If Not curve.IsLine Then ' si c'est une ligne, alors le principe de longueur ne fonctionnera pas...
2253 Dim longueur As Double = curve.GetLength2(bounds(0), bounds(1))
2254 If longueur < Epsilon Then Return False ' on a juste un point d'intersection
2255 Else
2256 Dim vParam As Object
2257 vParam = curve.GetClosestPointOn(P1(0), P1(1), P1(2)) ' vparam(3) est le U
2258
2259 P1 = curve.Evaluate(vParam(3) + 100000 * Epsilon) : Point1(0) = P1(0) : Point1(1) = P1(1) : Point1(2) = P1(2)
2260 P2 = curve.Evaluate(vParam(3) - 100000 * Epsilon) : Point2(0) = P2(0) : Point2(1) = P2(1) : Point2(2) = P2(2)
2261
2262 ' si p1 et p2 sont identiques alors on a un point D'intersection, ce que l'on ne veut pas
2263 If Distance(Point1, Point2) < 1000 * Epsilon Then Return False
2264
2265 If ((Distance(face1, Point1(0), Point1(1), Point1(2)) < (1000 * Epsilon)) AndAlso (Distance(face2, Point1(0), Point1(1), Point1(2)) < (1000 * Epsilon))) OrElse ((Distance(face1, Point2(0), Point2(1), Point2(2)) < (Epsilon * 1000)) AndAlso (Distance(face2, Point2(0), Point2(1), Point2(2)) < (1000 * Epsilon))) Then
2266 ' return true
2267 Else
2268 Dim swent2 As sldworks.Entity
2269 Dim feat2 As sldworks.Feature
2270 swModel.Insert3DSketch2(False)
2271 swModel.ClearSelection2(True)
2272 swent2 = face1 : swent2.Select2(False, 0)
2273 swent2 = face2 : swent2.Select2(True, 0)
2274 swModel.Sketch3DIntersections()
2275
2276 swModel.Insert3DSketch2(False)
2277 swModel.EditRebuild3()
2278 feat2 = swModel.FeatureByPositionReverse(0)
2279
2280 Sketch = feat2.GetSpecificFeature2
2281 feat2.Name = "TouchePas" & CStr(Rnd())
2282 Dim vSeg2 As Object = Sketch.GetSketchSegments()
2283 If vSeg2 Is Nothing Then
2284 swent2 = feat2
2285 swent2.Select(False)
2286 swModel.EditDelete()
2287 Return False
2288 Else
2289 Return True
2290 End If
2291 End If
2292 End If
2293
2294 Dim swent As sldworks.Entity
2295 Dim feat As sldworks.Feature
2296 swModel.Insert3DSketch2(False)
2297 swModel.ClearSelection2(True)
2298 swent = face1 : swent.Select2(False, 0)
2299 swent = face2 : swent.Select2(True, 0)
2300 swModel.Sketch3DIntersections()
2301
2302 swModel.Insert3DSketch2(False)
2303 swModel.EditRebuild3()
2304 feat = swModel.FeatureByPositionReverse(0)
2305
2306 Sketch = feat.GetSpecificFeature2
2307 Dim vSeg As Object = Sketch.GetSketchSegments()
2308 If vSeg Is Nothing Then
2309 swent = feat
2310 swent.Select(False)
2311 swModel.EditDelete()
2312 Return False
2313 Else
2314 Return True
2315 End If
2316
2317 Return True
2318
2319 End Function
2320
2321
2322 Public Function trier(ByRef lst() As Double) As Double()
2323 ' sub qui retourne les T min et T max en fonction de la collection.
2324 ' normalement on enlève les 2 points max et min et il devrait nous rester un nombre pair de valeurs.
2325 Dim i As Integer, j As Integer
2326 Dim lst2() As Double
2327
2328 Dim temp As Double
2329
2330 If UBound(lst) < 1 Then Return Nothing
2331
2332 For j = 0 To UBound(lst) - 1
2333 For i = 0 To UBound(lst) - j - 1
2334 If lst(i) > lst(i + 1) Then
2335 temp = lst(i)
2336 lst(i) = lst(i + 1)
2337 lst(i + 1) = temp
2338 End If
2339 Next i
2340 Next j
2341
2342 ReDim lst2(UBound(lst) - 2)
2343 For i = 1 To UBound(lst) - 1
2344 lst2(i - 1) = lst(i)
2345 Next
2346 Return lst2
2347
2348
2349
2350 End Function
2351
2352 ''' <summary>
2353 ''' Function qui remet en ordre croissant les valeurs d'un tableau
2354 ''' </summary>
2355 ''' <param name="lst">Le tableau de valeurs à ordonner</param>
2356 ''' <param name="liste2">un second tableau que l'on peut ordonner</param>
2357 ''' <returns></returns>
2358 ''' <remarks></remarks>
2359 Public Function Ordonner(ByRef lst() As Double, Optional ByRef liste2() As SldWorks.Edge = Nothing) As Double()
2360
2361 Dim i As Integer, j As Integer
2362 Dim temp2 As Object
2363
2364 Dim temp As Double
2365
2366 If UBound(lst) < 1 Then Return Nothing
2367
2368 For j = 0 To UBound(lst) - 1
2369 For i = 0 To UBound(lst) - j - 1
2370 If lst(i) > lst(i + 1) Then
2371 temp = lst(i)
2372 lst(i) = lst(i + 1)
2373 lst(i + 1) = temp
2374 If Not liste2 Is Nothing Then
2375 temp2 = liste2(i)
2376 liste2(i) = liste2(i + 1)
2377 liste2(i + 1) = temp2
2378 End If
2379
2380 End If
2381 Next i
2382 Next j
2383
2384 Return lst
2385
2386
2387
2388 End Function
2389
2390
2391 ''' <summary>
2392 ''' Sub qui fait comme le tavail de Antoine et Rémi et qui créé un fichier pour la carte de taille. Si l'option de pré-optimisation est enclenchée, la sub ne fait qu'ajouter des éléments au fichier .txt
2393 ''' </summary>
2394 ''' <remarks></remarks>
2395 Public Sub FairePreCarte()
2396
2397 Dim ligne_txt As String
2398 Dim fichier As System.IO.StreamWriter
2399 Dim EcartNodal As Double = Commun.ÉcartNodal
2400
2401 ' si le fichier pog n'est pas encore créé, on doit le faire...
2402 If Commun.NomFichierPog = Nothing Then
2403 ' la première ligne donne la boite englobante, la seconde la taille ENG
2404
2405 Dim path As String = Nothing
2406 Dim CMDialogl As New Windows.Forms.SaveFileDialog
2407 CMDialogl.DefaultExt = ".txt"
2408 CMDialogl.Filter = "Fichiers PoG (*.txt)|*.txt|Tout fichiers(*.*)|*.*"
2409
2410 CMDialogl.OverwritePrompt = True
2411 CMDialogl.Title = "Sélectionnez le fichier pour enregistrer les points"
2412 CMDialogl.ShowDialog()
2413 path = CMDialogl.FileName
2414 path = Txtpath(path) : Commun.NomFichierPog = path
2415 If path Is Nothing Or path = "" Then MsgBox("Aucun fichier sélectionné, sortie du programme!", MsgBoxStyle.Critical, "Erreur!")
2416
2417 fichier = System.IO.File.CreateText(path)
2418
2419 Dim vBox As Object = swPart.GetPartBox(True)
2420 Dim box() As Double = vBox
2421
2422 Dim centre(2) As Double ' le centre de la boite englobante
2423 Dim longueurs(2) As Double
2424
2425 centre(0) = (box(3) + box(0)) / 2
2426 centre(1) = (box(4) + box(1)) / 2
2427 centre(2) = (box(5) + box(2)) / 2
2428
2429 longueurs(0) = (box(3) - box(0)) * 1.25
2430 longueurs(1) = (box(4) - box(1)) * 1.25
2431 longueurs(2) = (box(5) - box(2)) * 1.25
2432
2433
2434 ligne_txt = CStr(centre(0) - longueurs(0) / 2) & " " & CStr(centre(1) - longueurs(1) / 2) & " " & CStr(centre(2) - longueurs(2) / 2) & " " & CStr(centre(0) + longueurs(0) / 2) & " " & CStr(centre(1) + longueurs(1) / 2) & " " & CStr(centre(2) + longueurs(2) / 2)
2435 fichier.WriteLine(Replace(ligne_txt, ",", "."))
2436
2437 fichier.WriteLine(Replace(CStr(EcartNodal), ",", "."))
2438 Else
2439 ' Le fichier pog existe déjà...
2440 fichier = System.IO.File.AppendText(Commun.NomFichierPog)
2441 'fichier.WriteLine(Replace(CStr(EcartNodal), ",", "."))
2442 End If
2443
2444
2445 ' *** C'est ici que le fun se passe.
2446
2447
2448 ' 1 - On parcourt toutes les faces, les listes sont déjà RE-crées, donc pas de multifaces
2449 For Each sFace As SlyFaceVolume In Commun.lst_FaceVolume
2450 sFace.MettrePointSurPOG(fichier)
2451 Next
2452
2453
2454
2455 ' *** Fin
2456 fichier.Close()
2457 End Sub
2458
2459 ''' <summary>
2460 ''' Fonction qui compare 2 surfaces
2461 ''' </summary>
2462 ''' <param name="swSurf1">La première surface</param>
2463 ''' <param name="swSurf2">La seconde</param>
2464 ''' <returns>Vrai si les 2 surfaces sont identiques, faux sinon</returns>
2465 ''' <remarks></remarks>
2466 Public Function ComparerSurfaces(ByRef swSurf1 As sldworks.Surface, ByRef swSurf2 As sldworks.Surface) As Boolean
2467 'swSurf1.GetBSurfParams2(True,False,
2468
2469
2470 If swSurf1.IsPlane And swSurf2.IsPlane Then
2471 Dim obj1 As Object = swSurf1.PlaneParams
2472 Dim obj2 As Object = swSurf2.PlaneParams
2473 For i As Integer = 0 To 2
2474 If Not Math.Abs(obj1(i) - obj2(i)) < Epsilon Then Return False
2475 Next
2476 Return True
2477 ElseIf swSurf1.IsBlending And swSurf2.IsBlending Then
2478 ' pas de blendingParams
2479
2480 ElseIf swSurf1.IsCone And swSurf2.IsCone Then
2481 Dim obj1 As Object = swSurf1.ConeParams
2482 Dim obj2 As Object = swSurf2.ConeParams
2483 For i As Integer = 0 To 7
2484 If Not Math.Abs(obj1(i) - obj2(i)) < Epsilon Then Return False
2485 Next
2486 Return True
2487
2488 ElseIf swSurf1.IsCylinder And swSurf2.IsCylinder Then
2489 Dim obj1 As Object = swSurf1.CylinderParams
2490 Dim obj2 As Object = swSurf2.CylinderParams
2491 For i As Integer = 0 To 6
2492 If Not Math.Abs(obj1(i) - obj2(i)) < Epsilon Then Return False
2493 Next
2494 Return True
2495 ElseIf swSurf1.IsForeign And swSurf2.IsForeign Then
2496 ' ???
2497 ElseIf swSurf1.IsOffset And swSurf2.IsOffset Then
2498 ' Pas de offsetParam
2499
2500 ElseIf swSurf1.IsParametric And swSurf2.IsParametric Then
2501 ' pas de ParametricParams
2502
2503 ElseIf swSurf1.IsRevolved And swSurf2.IsRevolved Then
2504 ' pas de revolvedparams
2505
2506 ElseIf swSurf1.IsSphere And swSurf2.IsSphere Then
2507 Dim obj1 As Object = swSurf1.SphereParams
2508 Dim obj2 As Object = swSurf2.SphereParams
2509
2510 For i As Integer = 0 To 3
2511 If Not Math.Abs(obj1(i) - obj2(i)) < Epsilon Then Return False
2512 Next
2513 Return True
2514 ElseIf swSurf1.IsSwept And swSurf2.IsSwept Then
2515 ' merde, il n'y a pas de Sweptparams
2516
2517 ElseIf swSurf1.IsTorus And swSurf2.IsTorus Then
2518 Dim obj1 As Object = swSurf1.TorusParams
2519 Dim obj2 As Object = swSurf2.TorusParams
2520
2521 For i As Integer = 0 To 7
2522 If Not Math.Abs(obj1(i) - obj2(i)) < Epsilon Then Return False
2523 Next
2524 Return True
2525 Else
2526 ' faut quand même évaluer si on a la bonne chose...
2527 Dim obj As Object = swSurf1.GetClosestPointOn(0, 0, 0) ' x, y , z, U, V
2528
2529 Dim obj1 As Object = swSurf1.EvaluateAtPoint(obj(0), obj(1), obj(2))
2530 Dim obj2 As Object = swSurf1.EvaluateAtPoint(obj(0), obj(1), obj(2))
2531
2532 If Math.Abs(obj1(9) - obj2(9)) < Epsilon And Math.Abs(obj1(10) - obj2(10)) < Epsilon Then
2533 ' c'est cheap.... mais
2534 Return True
2535 End If
2536 Return False
2537
2538 End If
2539
2540 Return False
2541
2542
2543
2544 End Function
2545
2546
2547 End Module