Export de points au format STEP

Out of category
21

Bonjour, essaye ca sur un assemblage

Option Explicit
Dim fileNum As Integer
Dim lineNum As Integer
Dim swMathUtil As SldWorks.MathUtility

Sub main()
  Dim swApp As SldWorks.SldWorks
  Dim swModel As SldWorks.ModelDoc2
  Dim swConf As SldWorks.Configuration
  Dim swRootComp As SldWorks.Component2
  Dim filePath As String
  Set swApp = Application.SldWorks
  Set swMathUtil = swApp.GetMathUtility
  Set swModel = swApp.ActiveDoc
  If swModel Is Nothing Then
    MsgBox "Ouvrir un assemblage ou une pièce"
    Exit Sub
  End If
  If swModel.GetType = swDocumentTypes_e.swDocDRAWING Then
    MsgBox "Ouvrir un assemblage ou une pièce"
    Exit Sub
  End If
  
  filePath = Left(swModel.GetPathName, InStrRev(swModel.GetPathName, ".") - 1) & ".STEP"
  fileNum = FreeFile
  Open filePath For Output As #fileNum
  
  PrintTxt "ISO-10303-21;"
  PrintTxt "HEADER;"
  PrintTxt "FILE_DESCRIPTION (( 'STEP AP214' ), '1');"
  PrintTxt "FILE_NAME ('" & swModel.GetTitle & "', '', ('JeromeP'), (''), 'ExportePointsEnStepMacro', 'SolidWorks', '');"
  PrintTxt "ENDSEC;"
  PrintTxt "DATA;"
  
  lineNum = 0
  If swModel.GetType = swDocumentTypes_e.swDocASSEMBLY Then
    Set swConf = swModel.GetActiveConfiguration
    Set swRootComp = swConf.GetRootComponent3(True)
    TraverseComponent swRootComp
  Else
    TraverseFeat swModel, Nothing
  End If

  PrintSet Empty

  PrintTxt "ENDSEC;"
  PrintTxt "END-ISO-10303-21;"
  Close #fileNum
  MsgBox "Exporté dans: " & vbCr & filePath
End Sub

Sub PrintTxt(myTxt As String)
  Print #fileNum, myTxt
End Sub


Sub TraverseComponent(swComp As SldWorks.Component2)
  Dim vChilds As Variant
  Dim vChild As Variant
  Dim swChildComp As SldWorks.Component2
  Dim compTransform As SldWorks.MathTransform
  Dim swModel As SldWorks.ModelDoc2
  Dim swPart As SldWorks.PartDoc
  Dim vBoundBox As Variant
  Dim swMass As SldWorks.MassProperty
  vChilds = swComp.GetChildren
  For Each vChild In vChilds
    Set swChildComp = vChild
    Set compTransform = swChildComp.Transform2
    'Debug.Print swChildComp.Name2'
    Set swModel = swChildComp.GetModelDoc2
    If swModel.GetType = swDocumentTypes_e.swDocPART Then
      TraverseFeat swModel, compTransform
    End If
    TraverseComponent swChildComp
  Next
End Sub

Sub TraverseFeat(ByVal swModel As SldWorks.ModelDoc2, ByVal Xform As SldWorks.MathTransform)
  Dim swFeat As SldWorks.Feature
  Dim swSubFeat As SldWorks.Feature
  Set swFeat = swModel.FirstFeature
  While Not swFeat Is Nothing
    ProcessFeat swFeat, Xform
    Set swSubFeat = swFeat.GetFirstSubFeature
    While Not swSubFeat Is Nothing
      ProcessFeat swSubFeat, Xform
      Set swSubFeat = swSubFeat.GetNextSubFeature
    Wend
    Set swFeat = swFeat.GetNextFeature
  Wend
End Sub

Sub ProcessFeat(ByVal swFeat As SldWorks.Feature, ByVal Xform As SldWorks.MathTransform)
  Dim swSketch As SldWorks.Sketch
  Dim swPt As SldWorks.SketchPoint
  Dim vPts As Variant
  Dim vPt As Variant
  Dim mPt As SldWorks.MathPoint
  Dim nPt(2) As Double
  'Debug.Print swfeat.Name & " " & swfeat.GetTypeName2'
  If swFeat.GetTypeName2 = "ProfileFeature" Or swFeat.GetTypeName2 = "3DProfileFeature" Then
    Set swSketch = swFeat.GetSpecificFeature2
    vPts = swSketch.GetSketchPoints
    For Each vPt In vPts
      Set swPt = vPt
      If Not swPt Is Nothing Then
        If swPt.Type = swSketchPointType_e.swSketchPointType_User Then
          lineNum = lineNum + 1
          nPt(0) = swPt.X: nPt(1) = swPt.Y: nPt(2) = swPt.Z
          If Not Xform Is Nothing Then
            Set mPt = swMathUtil.CreatePoint(nPt)
            Set mPt = mPt.MultiplyTransform(Xform)
            nPt(0) = mPt.ArrayData(0)
            nPt(1) = mPt.ArrayData(1)
            nPt(2) = mPt.ArrayData(2)
          End If
          PrintTxt "#" & lineNum & " = CARTESIAN_POINT ( 'PNT" & lineNum & "', ( " & nPt(0) * 1000 & "E-3, " & nPt(1) * 1000 & "E-3, " & nPt(2) * 1000 & "E-3 ) ) ;"
        End If
      End If
    Next
  End If
End Sub

Sub PrintSet(void)
  Dim myTxt As String
  Dim j As Integer
  myTxt = "#" & lineNum + 1 & " = GEOMETRIC_SET('',(#"
  For j = 1 To lineNum - 1
    myTxt = myTxt & j & ", #"
  Next j
  myTxt = myTxt & lineNum & "));"
  PrintTxt myTxt
End Sub

 

1 « J'aime »
24

Bonjour JérômeP,

Merci d'avoir pris mon relais pour répondre à Aurélien pendant que j'étais en vacances. En plus les notifications de nouveaux postes ne semblent plus marcher chez moi alors je n'allais pas répondre.

M.

PS : Aurélien, si la macro de Jérôme fonctionne bien, pourrais tu sélectionner sa réponse comme meilleur réponse ? C'est pour clore le fil de discussion.

2 « J'aime »