- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
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.
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:
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
Solved! Go to Solution.
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
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
Mass Override for Each Model State
Custom Glyph Icon for iMates
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
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
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hello Clutsa,
thanks for your solution, axactly what i wanted!
Regards from Germany...
Martin