Extraire coordonnées de points d'un dossier de composants

3D Design
1

Bonjour, j'ai besoin de créer une macro qui extrait sur un fichier excel tous les points des composants d'un dossier, j'arrive a faire une extraction mais je dois d'abord sélectionner un point d'une esquisse (code trouvé sur le forum).

Alors ma question est : comment sélectionner tous les points d'un dossier avec le nom du dossier de composants ? Quelle serait la fonction a utiliser/remplacer ?

 

Dim swApp As SldWorks.SldWorks
Dim Part As SldWorks.ModelDoc2
Dim boolstatus As Boolean
Dim longstatus As Long
Dim Annotation As Object
Dim Gtol As Object
Dim DatumTag As Object
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Public Pfx As String
Dim myNote As SldWorks.Note
Dim SelMgr As SldWorks.SelectionMgr
Dim mySketchPoint As SldWorks.SketchPoint
Dim mySketch As SldWorks.sketch
Dim AllSketchPoints As Variant
Const FMAT As String = "0.00"
Const SF As Double = 1000
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Const FirstRow As Long = 4
Const FirstCol As Long = 2
Dim CurRow As Long
Dim IDCol As Long
Dim Xcol As Long
Dim Ycol As Long
Dim Zcol As Long
Dim PtID As Variant
Dim i As Long

Sub test2()

Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set SelMgr = Part.SelectionManager

If (SelMgr.GetSelectedObjectType3(1, -1) <> 11) And (SelMgr.GetSelectedObjectType3(1, -1) <> 25) Then
    MsgBox "Select a sketch point of a 3D sketch and run macro again"
    Exit Sub
End If

Set mySketchPoint = SelMgr.GetSelectedObject6(1, -1)
Set mySketch = mySketchPoint.GetSketch
AllSketchPoints = mySketch.GetSketchPoints2

Set xlApp = CreateObject("Excel.Application")
xlApp.Visible = True
Set xlBook = xlApp.Workbooks.Add
Set xlSheet = xlBook.Worksheets("feuil1")

CurRow = FirstRow
IDCol = FirstCol
Xcol = FirstCol + 1
Ycol = FirstCol + 2
Zcol = FirstCol + 3
xlSheet.Cells(CurRow, IDCol).Value = "'Point ID"
xlSheet.Cells(CurRow, Xcol).Value = "'X Coord"
xlSheet.Cells(CurRow, Ycol).Value = "'Y Coord"
xlSheet.Cells(CurRow, Zcol).Value = "'Z Coord"
CurRow = CurRow + 1

For i = 0 To UBound(AllSketchPoints)
    PtID = AllSketchPoints(i).GetID
    xlSheet.Cells(CurRow, IDCol).Value = PtID(0) & "," & PtID(1)
    xlSheet.Cells(CurRow, Xcol).Value = Format(AllSketchPoints(i).X * SF, FMAT)
    xlSheet.Cells(CurRow, Ycol).Value = Format(AllSketchPoints(i).Y * SF, FMAT)
    xlSheet.Cells(CurRow, Zcol).Value = Format(AllSketchPoints(i).Z * SF, FMAT)
    CurRow = CurRow + 1
Next i


Part.ClearSelection
Part.WindowRedraw

End Sub

 

2

J'ai trouvé la solution. Voici le code :

Sub test5()

    'Declaration des variables
    Dim swApp As SldWorks.SldWorks
    Dim swModel As SldWorks.ModelDoc2
    Dim swSelMgr As SldWorks.SelectionMgr
    Dim swSketch As SldWorks.sketch
    Dim swFeat As SldWorks.Feature
    Dim swSketchPoint As SldWorks.SketchPoint
    Dim sketchPointArray As Variant
    Dim i As Long
    Dim xValue As Double
    Dim yValue As Double
    Dim zValue As Double
    Dim IDvalue As String
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet
    Const FirstRow As Long = 4
    Const FirstCol As Long = 2
    Dim CurRow As Long
    Dim sktch As String
    
    sktch = "sketch3"
    
    'initialisation des variables
    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    boolstatus = swModel.Extension.SelectByID2(sktch, "SKETCH", 0, 0, 0, False, 0, Nothing, 0)
    Set swSelMgr = swModel.SelectionManager
    Set swFeat = swSelMgr.GetSelectedObject6(1, -1)
    Set swSketch = swFeat.GetSpecificFeature2
    Set xlApp = CreateObject("Excel.Application")
    xlApp.Visible = True
    Set xlBook = xlApp.Workbooks.Add
    Set xlSheet = xlBook.Worksheets("feuil1")
    CurRow = FirstRow
    
    'initialisation du classeur excel
    IDCol = FirstCol
    Xcol = FirstCol + 1
    Ycol = FirstCol + 2
    Zcol = FirstCol + 3
    xlSheet.Cells(CurRow, IDCol).Value = "'Point ID"
    xlSheet.Cells(CurRow, Xcol).Value = "'X Coord"
    xlSheet.Cells(CurRow, Ycol).Value = "'Y Coord"
    xlSheet.Cells(CurRow, Zcol).Value = "'Z Coord"
    CurRow = CurRow + 1

    'copie des coordonnées de points dans le classeur
    sketchPointArray = swSketch.GetSketchPoints2
    'For i = 0 To UBound(sketchPointArray)
    Do While i < UBound(sketchPointArray)
        'récupération des points
        Set swSketchPoint = sketchPointArray(i)
        Debug.Print "Value returned by ISketchPoint::GetCoords: " & swSketchPoint.GetCoords
        'recupération des coordonées des pts
        xValue = sketchPointArray(i).X
        yValue = sketchPointArray(i).Y
        zValue = sketchPointArray(i).Z
        IDvalue = swSketchPoint.IGetID
        
        'copie des coordonnées sur excel
        xlSheet.Cells(CurRow, 2).Value = IDvalue
        xlSheet.Cells(CurRow, 3).Value = xValue
        xlSheet.Cells(CurRow, 4).Value = yValue
        xlSheet.Cells(CurRow, 5).Value = zValue
      CurRow = CurRow + 1
      i = i + 1
    Loop 'Next i

End Sub