Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.
clutsa
in reply to: martinhoos

This is the simplest thing I could come up with... you may need to change "Center Point" to "Mittelpunkt" (based on the comments in your code I'm assuming the German word for center point)

Sub ExportArbeitspunkte()
    Dim app As Application
    Set app = ThisApplication
    
    Dim oDoc As PartDocument
    Set oDoc = ThisApplication.ActiveDocument
   
    Dim oDef As PartComponentDefinition
    Set oDef = oDoc.ComponentDefinition
   
    Dim oWorkpoints As WorkPoints
    Dim oWP As WorkPoint
    Dim oP As Point
       
    'get all workpoints in this part
    Set oWorkpoints = oDef.WorkPoints
    
    'Create a new Excel instance
    Dim oExcelApplication As Excel.Application
    Set oExcelApplication = New Excel.Application

    'create a new excel workbook
    Dim oBook As Excel.Workbook
    Set oBook = oExcelApplication.Workbooks.Add()
    Dim oSheet As Excel.WorkSheet
    Set oSheet = oBook.ActiveSheet
   
    Dim nRow As Integer
    nRow = 1
    
    'Ask for Origin point
    Dim MyOrg As WorkPoint
    Set MyOrg = app.CommandManager.Pick(kAllPointEntities, "Choose sweep origin")
    
    'find difference to center point
Dim DeltaX As Double Dim DeltaY As Double Dim DeltaZ As Double DeltaX = oDef.WorkPoints.Item("Center Point").Point.x - MyOrg.Point.x DeltaY = oDef.WorkPoints.Item("Center Point").Point.Y - MyOrg.Point.Y DeltaZ = oDef.WorkPoints.Item("Center Point").Point.Z - MyOrg.Point.Z 'write the coordinates into separate columns, one workpoint each row For Each oWP In oWorkpoints If Not oWP.Name = "Center Point" Then Set oP = oWP.Point oSheet.Cells(nRow, 1) = (oP.x + DeltaX) * 10 oSheet.Cells(nRow, 2) = (oP.Y + DeltaY) * 10 oSheet.Cells(nRow, 3) = (oP.Z + DeltaZ) * 10 nRow = nRow + 1 End If Next Dim OutputFile As String OutputFile = Left(ThisApplication.ActiveDocument.FullFileName, _ Len(ThisApplication.ActiveDocument.FullFileName) - 4) + "_Arbeitspunkte.xls" On Error Resume Next oBook.SaveAs (OutputFile) oBook.Close Set oBook = Nothing Set oSheet = Nothing Set oExcelApplication = Nothing MsgBox "Es wurde eine Excel Tabelle im aktuellen Verzeichnis erstellt und eine neue IPT für den Import geöffnet!" 'Make a new part file Dim oPartDoc As PartDocument 'Set oPartDoc = ThisApplication.Documents.Add(kPartDocumentObject, ThisApplication.FileManager.GetTemplateFile(kPartDocumentObject)) Set oPartDoc = ThisApplication.Documents.Add(kPartDocumentObject, , True) End Sub

Edit: Don't forget to put your template path back in on the last line

If I've helped you, please help me by supporting this idea.
Mass Override for Each Model State

Custom Glyph Icon for iMates