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

Pipe (sweep) and workpoints

martinhoos
Advocate

Pipe (sweep) and workpoints

martinhoos
Advocate
Advocate

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

0 Likes
Reply
Accepted solutions (1)
464 Views
3 Replies
Replies (3)

clutsa
Collaborator
Collaborator
Accepted solution

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

0 Likes

JamieVJohnson2
Collaborator
Collaborator

Another method is to exclude the Center workpoint (which is always workpoints item 1) from your iteration.

Instead of 'for each workpoint...', use:

for ind as integer = 2 to oWorkpoints.count

dim wp as workpoint = oWorkpoints(ind)

'do work

next

jvj
0 Likes

martinhoos
Advocate
Advocate

Hello Clutsa,

thanks for your solution, axactly what i wanted!

Regards from Germany...

Martin

0 Likes