01-02-2019
01:08 PM
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
01-02-2019
01:08 PM
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
Mass Override for Each Model State
Custom Glyph Icon for iMates