Gaine souple perso

[sechanbask]

Bonjour, comme je suis fou (merci fisacad) j'ai commencé à créer une commande pour me tracer de la gaine souple... ça marche mais y'a des améliorations à apporter :

 

1 : ça fonctionne si le dessin est en millimètre, en centimètre en mètre mais pas sur tout les postes. Sur certains postes je ne peux pas dessiner la gaine si le plan est en mètre... si quelqu'un pouvait m'aider...

 

2 ajuster automatiquement la gaine et la faire partir avec une tangente = à la direction de la gain circulaire rigide précédemment dessinée

 

3 faire en sorte que ça marche quelque soit le SCU, SGC

 

4 faire un bloc à la fin de l'opération en ajoutant un attribut invisible avec la longueur (pour cumuler la quantité de gaine

 

5 si possible que la commande me prépare un thé à chaque gaine réussie (donc à chaque gaine.. car j'en ai marre d'avoir soif, là faute à fisacad ! )

 

Dim color As AcadAcCmColor
Dim newlayer2 As AcadLayer
Dim linetypeName1 As String
Public coef As Double
Dim actlayer As String

Sub Gaine_souple()
  
  
  Dim splineObj As AcadSpline
  Dim splineObj1 As AcadSpline
  Dim splineObj2 As AcadSpline
  
  Dim startTan(0 To 2) As Double
  Dim endTan(0 To 2) As Double
  Dim pins As Variant
  Dim diametre As Double
  Dim fitPoints(0 To 8) As Double
  Dim unitvar As String
  Dim coef As Double
   Dim coeftypeline As Double
'On Error GoTo gserror


unitvar = ThisDrawing.GetVariable("INSUNITS")
    Select Case unitvar

Case 4
'(millimètre)
coeftypeline = 1
coef = 1
Case 5
'(centimètre)
coef = 0.1
coeftypeline = 0.1
Case 6
'(mètre)

coef = 0.001
coeftypeline = 0.0005
Dim nombre2zéro As Integer
nombre2zéro = 4
Dim variable As String
variable = "LUPREC"
ThisDrawing.SetVariable variable, nombre2zéro

End Select



diametre = ThisDrawing.Utility.GetReal("Veuillez indiquer le diamètre de la gaine en mm : ")
diametre = diametre * coef
calque_tout

 startTan(0) = 0: startTan(1) = 0: startTan(2) = 0
 endTan(0) = 0: endTan(1) = 0: endTan(2) = 0

  pins = ThisDrawing.Utility.GetPoint(, vbCrLf & "premier point:")
  fitPoints(0) = pins(0): fitPoints(1) = pins(1): fitPoints(2) = 0

  pins = ThisDrawing.Utility.GetPoint(, vbCrLf & "deuxième point:")
  fitPoints(3) = pins(0): fitPoints(4) = pins(1): fitPoints(5) = 0

  pins = ThisDrawing.Utility.GetPoint(, vbCrLf & "troisième point:")
  fitPoints(6) = pins(0): fitPoints(7) = pins(1): fitPoints(8) = 0

'   pins = ThisDrawing.Utility.GetPoint(, vbCrLf & "quatrième point:")
'    fitPoints(9) = pins(0): fitPoints(10) = pins(1): fitPoints(11) = pins(0)
  'pins = ThisDrawing.Utility.GetPoint(, vbCrLf & "quatrième point:")
  'fitPoints(8) = pins(0): fitPoints(9) = pins(1)
  'pins = ThisDrawing.Utility.GetPoint(, vbCrLf & "quatrième point:")
  'fitPoints(10) = pins(0): fitPoints(11) = pins(1)
    Set splineObj = ThisDrawing.ModelSpace.AddSpline(fitPoints, startTan, endTan)
  With splineObj
  .Layer = actlayer
  .Linetype = "ZIGZAG"
  .LinetypeScale = coeftypeline
  .Update
  End With


'On Error Resume Next
  Dim offsetvar As Variant
  'diametre = 2
  
  
  offsetvar = splineObj.Offset(diametre / 2)

  offsetvar = splineObj.Offset(-diametre / 2)

newlayer2.Linetype = "AXES"

  With splineObj
  .Layer = actlayer & "-A"
  .LinetypeScale = 1 * coef
  .Linetype = linetypeName1
  .Update
  End With
  Exit Sub

gserror:
Select Case Err.Number
Case "-2145386493"
MsgBox "La gaine ne peut pas s'afficher car les unités de votre fichier (définies dans Fromat- Contrôles des unités ou ligne de commande UNITS) ne correspondent pas aux unités de votre plan."
Case "-2147352567"
ThisDrawing.Utility.Prompt "Annulée par l'utilisateur."
Case Else
Debug.Print Err.Number, Err.Description
ThisDrawing.Utility.Prompt "Une erreur inconnue est survenue, veuillez contacter le développeur."
End Select
End Sub
Function calque_tout()


Dim newlayer1 As AcadLayer

Dim linetypeName As String

Dim trouve As Boolean
Dim var As String
Dim fichier1 As String
Dim soulayer As ACAD_LAYER
Dim layers As AcadLayers


actlayer = ThisDrawing.ActiveLayer.Name
Set newlayer1 = ThisDrawing.layers.Add(actlayer)

'Set color = AcadApplication.GetInterfaceObject("AutoCAD.AcCmColor.16")
'Call color.SetRGB(80, 100, 244)
'For Each soulayer In layers
'if actlayer & "A" like
'Next

Set newlayer2 = ThisDrawing.layers.Add(actlayer & "-A")


     linetypeName = "ZIGZAG"
     Dim entry As AcadObject
  For Each entry In ThisDrawing.Linetypes
      If StrComp(entry.Name, linetypeName, 1) = 0 Then
'MsgBox linetypeName & " a été trouvé dans dessin actif."
            trouve = True
      Exit For
  Else
    End If
   Next
    If trouve = False Then
        var = ThisDrawing.GetVariable("MEASUREMENT")
  If var = 0 Then
  ThisDrawing.SetVariable "MEASUREMENT", 1
  var = ThisDrawing.GetVariable("MEASUREMENT")
  'MsgBox "Le système des unités est initialisé en unités S.I."
  End If
  fichier1 = "acadiso.lin"
     ThisDrawing.Linetypes.Load linetypeName, "acadiso.lin"
  'MsgBox "trouvé dans fichier..."
  Else
      End If
trouve = False



     linetypeName1 = "AXES"
     For Each entry In ThisDrawing.Linetypes
      If StrComp(entry.Name, linetypeName1, 1) = 0 Then
'MsgBox linetypeName & " a été trouvé dans dessin actif."
             trouve = True
      Exit For
  Else
    End If
   Next
    If trouve = False Then
  var = ThisDrawing.GetVariable("MEASUREMENT")
  If var = 0 Then
  ThisDrawing.SetVariable "MEASUREMENT", 1
  var = ThisDrawing.GetVariable("MEASUREMENT")
  'MsgBox "Le système des unités est initialisé en unités S.I."
  End If
  fichier1 = "acadiso.lin"
     ThisDrawing.Linetypes.Load linetypeName1, "acadiso.lin"
  'MsgBox "trouvé dans fichier..."
  Else
      End If

    'MsgBox "le calque NOM DU CALQUE a pour type de ligne : " & linetypeName
 End Function