Announcements
Attention for Customers without Multi-Factor Authentication or Single Sign-On - OTP Verification rolls out April 2025. Read all about it here.
martinhoos
466 Views, 3 Replies

Pipe (sweep) and workpoints

Hello,

i have a code which exports workpoints to an excel file. I need the coordinates of the workpoints to create a sweeping of a pipe. the code exports the workpoints and the zeropoint (0,0,0). This zeropoint is not a point of the pipe. - only the 4 workpoints.

 

workpoints.JPG

 

excel.JPG

 

Is it possible to change the code that i can choose a workpoint? This workpoint shouldt be the new startpoint (0,0,0) for the sweeping. The code shouldt be take the coordinates of this choosen workpoint and calculate the new coordinates for all the other 4 points (not for the original zeropint).

 

For example, if i choose the Point -100,-300,100 the Excel file shouldt Looks like this:

 

excel1.JPG

 

This is my code:

Sub ExportArbeitspunkte()
    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

    'write the coordinates into separate columns, one workpoint each row
    For Each oWP In oWorkpoints
        Set oP = oWP.Point
        oSheet.Cells(nRow, 1) = oP.X * 10
        oSheet.Cells(nRow, 2) = oP.Y * 10
        oSheet.Cells(nRow, 3) = oP.Z * 10
        nRow = nRow + 1
    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, "V:\Inventor-2015\1-Inventor\TEMPLATES\_VORLAGE ROHR.ipt")

End Sub

 

Thank you in advance for your help.

Regards from germany

Martin