Hallo Helmut,
erstmals vielen dank für deine Bereitschaft mir zu helfen. Hier sind die zwei VBA Skripte, ein Skript um die Punkte aus Inventor auszulesen und ein Skript um die Punkte einzulesen. Der Skript der die Punkte ausließt importiert keine Punktnamen.(Die Excel Tabelle muss immer offen sein, damit man die Punkte importiert).
Vielen Dank nochmals und einen schönen Start in die Arbeitswoche. 
VBA Skript um die Punkte auszulesen:
Sub ExportWorkpoints_ipt()
' Get the active part document.
Dim partDoc As PartDocument
If ThisApplication.ActiveDocumentType = kPartDocumentObject Then
Set partDoc = ThisApplication.ActiveDocument
Else
MsgBox "Ein Bauteil (*.ipt) muss geöffnet bzw. aktiv sein."
Exit Sub
End If
' Check to see if any work points are selected.
Dim points() As WorkPoint
Dim pointCount As Long
pointCount = 0
If partDoc.SelectSet.Count > 0 Then
' Dimension the array so it can contain the full
' list of selected items.
ReDim points(partDoc.SelectSet.Count - 1)
Dim selectedObj As Object
For Each selectedObj In partDoc.SelectSet
If TypeOf selectedObj Is WorkPoint Then
Set points(pointCount) = selectedObj
pointCount = pointCount + 1
End If
Next
ReDim Preserve points(pointCount - 1)
End If
' Ask to see if it should operate on the selected points
' or all points.
Dim getAllPoints As Boolean
getAllPoints = True
If pointCount > 0 Then
Dim result As VbMsgBoxResult
result = MsgBox("Einige Arbeitspunkte sind ausgewählt. " & _
"Sollen nur die ausgewählten Arbeitspunkte " & _
"exportiert werden? " & Chr(13) & Chr(13) & _
"(Antwort ""Nein"" exportiert alle Arbeitspunkte)", _
vbQuestion + vbYesNoCancel)
If result = vbCancel Then
Exit Sub
End If
If result = vbYes Then
getAllPoints = False
End If
Else
If MsgBox("Es sind keine Arbeitspunkte ausgewählt. Alle Arbeitspunkte" & Chr(13) & _
" werden exportiert. " & Chr(13) & Chr(13) & "Möchten Sie fortfahren?", _
vbQuestion + vbYesNo) = vbNo Then
Exit Sub
End If
End If
Dim partDef As PartComponentDefinition
Set partDef = partDoc.ComponentDefinition
If getAllPoints Then
ReDim points(partDef.WorkPoints.Count - 1) 'um den Mittelpunkt auszulassen muss anstelle von -1 hier -2 stehen
' Get all of the workpoints.
' for skipping the first, which is the origin point, i must start with 2
Dim i As Integer
For i = 1 To partDef.WorkPoints.Count 'um den Mittelpunkt auszulassen muss für anstelle von 1 hier 2 stehen
Set points(i - 1) = partDef.WorkPoints.Item(i) 'um den Mittelpunkt auszulassen muss anstelle von -1 hier -2 stehen
Next
End If
'-----------------------------------------------------------------------
' Abfrage Weltkoordinaten
'-----------------------------------------------------------------------
Dim WeltKoorDia As VbMsgBoxResult
WeltKoorDia = MsgBox("Wollen Sie Werte für Weltkoordinaten eingeben? " & Chr(13) & Chr(13) & _
"Die einzugebenden Werte entsprechen den Weltkoordinaten des Mittelpunktes " & Chr(13) & _
"und werden zu den ausgelesenen Koordinatenwerten der Arbeitspunkte hinzuaddiert.", _
vbQuestion + vbYesNoCancel)
If WeltKoorDia = vbCancel Then
Exit Sub
End If
If WeltKoorDia = vbYes Then
Dim xCoordWelt As Double
Dim yCoordWelt As Double
Dim zCoordWelt As Double
Dim Welt_Winkel_Wert As Double, Welt_Winkel As Double
WeltKoor.Show
xCoordWelt = WeltKoor.txt_x
yCoordWelt = WeltKoor.txt_y
zCoordWelt = WeltKoor.txt_z
Welt_Winkel_Wert = WeltKoor.txt_grd
Welt_Winkel = Welt_Winkel_Wert * 3.14159265359 / 180
End If
'-----------------------------------------------------------------------
' Dialog zum Erstellen der Dateien
'-----------------------------------------------------------------------
' Get the filename to write to.
Dim dialog As FileDialog
Dim Dateiname_xls As String
Dateiname_xls = Left(ThisApplication.ActiveDocument.FullFileName, _
Len(ThisApplication.ActiveDocument.FullFileName) - 4) + ".xls"
Call ThisApplication.CreateFileDialog(dialog)
With dialog
.DialogTitle = "Ausgabedatei *.XLS-Format"
.Filter = "Microsoft Office Excel-Datei (*.xls)|*.xls"
.FilterIndex = 0
.OptionsEnabled = False
.MultiSelectEnabled = False
.CancelError = False
.filename = Dateiname_xls
.ShowSave
Dateiname_xls = .filename
End With
'-----------------------------------------------------------------------
' Erstellen der Excel-Datei im *.csv-Format
'-----------------------------------------------------------------------
Dim filename_csv As String
If Dateiname_xls <> "" And Len(Dateiname_xls) >= 4 Then
Dateiname_csv = Left(Dateiname_xls, Len(Dateiname_xls) - 4) + ".csv"
' Write the work point coordinates out to a csv file.
On Error Resume Next
Open Dateiname_csv For Output As #1
If Err.Number <> 0 Then
MsgBox "Die angegebene Datei kann nicht geöffnert werden. " & _
"Die Datei ist eventuell durch einen anderen Prozess geöffnet."
Exit Sub
End If
' Get a reference to the object to do unit conversions.
Dim uom As UnitsOfMeasure
Set uom = partDoc.UnitsOfMeasure
' Write the points, taking into account the current default
' length units of the document.
Print #1, "Bezeichnung" & " " & _
"X-Koordinate" & " " & _
"Y-Koordinate" & " " & _
"Z-Koordinate"
For i = 0 To UBound(points)
Dim xCoord As Double
xCoord = uom.ConvertUnits(points(i).Point.X, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
Dim yCoord As Double
yCoord = uom.ConvertUnits(points(i).Point.Y, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
Dim zCoord As Double
zCoord = uom.ConvertUnits(points(i).Point.Z, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
Print #1, points(i).Name & " " & _
Format(Cos(Welt_Winkel) * xCoord - Sin(Welt_Winkel) * yCoord + xCoordWelt, "0.000") & " " & _
Format(Sin(Welt_Winkel) * xCoord + Cos(Welt_Winkel) * yCoord + yCoordWelt, "0.000") & " " & _
Format(zCoord + zCoordWelt, "0.000")
Next
Close #1
Else
Exit Sub
End If
'-----------------------------------------------------------------------
' Erstellen der Excel-Datei im *.xls-Format
'-----------------------------------------------------------------------
'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 = 2
'Spaltenüberschriften
oSheet.Cells(1, 1) = "Bezeichnung"
oSheet.Cells(1, 1).Font.Bold = True
oSheet.Cells(1, 2) = "X-Koordinate"
oSheet.Cells(1, 2).Font.Bold = True
oSheet.Cells(1, 3) = "Y-Koordinate"
oSheet.Cells(1, 3).Font.Bold = True
oSheet.Cells(1, 4) = "Z-Koordinate"
oSheet.Cells(1, 4).Font.Bold = True
'write the coordinates into separate columns, one workpoint each row
For i = 0 To UBound(points)
xCoord = uom.ConvertUnits(points(i).Point.X, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
yCoord = uom.ConvertUnits(points(i).Point.Y, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
zCoord = uom.ConvertUnits(points(i).Point.Z, _
kCentimeterLengthUnits, kDefaultDisplayLengthUnits)
oSheet.Cells(nRow, 1) = points(i).Name
oSheet.Cells(nRow, 2) = Cos(Welt_Winkel) * xCoord - Sin(Welt_Winkel) * yCoord + xCoordWelt
oSheet.Cells(nRow, 3) = Sin(Welt_Winkel) * xCoord + Cos(Welt_Winkel) * yCoord + yCoordWelt
oSheet.Cells(nRow, 4) = zCoord + zCoordWelt
nRow = nRow + 1
Next
oSheet.Columns(1).EntireColumn.AutoFit
oSheet.Columns(2).EntireColumn.AutoFit
oSheet.Columns(3).EntireColumn.AutoFit
oSheet.Columns(4).EntireColumn.AutoFit
oSheet.Cells(nRow + 1, 1) = ThisApplication.ActiveDocument.FullFileName
On Error Resume Next
oBook.SaveAs (Dateiname_xls)
oBook.Close
Set oBook = Nothing
Set oSheet = Nothing
Set oExcelApplication = Nothing
'-----------------------------------------------------------------------
MsgBox "Das Schreiben der Dateien ist beendet. " & Chr(13) & Chr(13) & _
"Die Daten befinden sich in den beiden Dateien: " & Chr(13) & Chr(13) & _
"- """ & Dateiname_xls & "" & Chr(13) & _
"- """ & Dateiname_csv & """"
'Microsoft Excel starten und ein bestehendes Worksheet-Objekt öffnen.
Set ExcelWorkSheet = GetObject("Dateiname_xls")
End Sub
Skript um die punkte einzulesen:
Option Explicit
Private oExcel As Excel.Application
Private oSheet As Excel.WorkSheet
Private oPartDoc As PartDocument
Private Sub CloseSpline_Click()
End Sub
Private Sub UserForm_Initialize()
Set oPartDoc = ThisApplication.ActiveDocument
Set oExcel = GetObject(, "Excel.Application")
Set oSheet = oExcel.ActiveSheet
End Sub
Private Sub UserForm_Terminate()
Set oPartDoc = Nothing
Set oExcel = Nothing
Set oSheet = Nothing
End Sub
Private Sub Create3DSpline_Click()
If Create3DSpline.Value = True Then
Createpolyline.Value = False
CloseSpline.Enabled = True
Createpolyline.Value = False
Else
CloseSpline.Enabled = False
Createpolyline.Value = True
End If
End Sub
Private Sub CreatePolyline_Click()
If Createpolyline.Value = True Then
Create3DSpline.Value = False
CloseSpline.Enabled = False
Closepolyline.Enabled = True
Else
Closepolyline.Enabled = False
Create3DSpline.Value = True
End If
End Sub
Private Sub OKButton_Click()
Dim bCreateSpline As Boolean
Dim bCreatePolyline As Boolean
bCreateSpline = Create3DSpline.Value
bCreatePolyline = Createpolyline.Value
Dim bCloseSpline As Boolean
bCloseSpline = CloseSpline.Value
Dim bClosePolyline As Boolean
bClosePolyline = Closepolyline.Value
ThisApplication.UserInterfaceManager.UserInteractionDisabled = True
Dim oDef As PartComponentDefinition
Set oDef = oPartDoc.ComponentDefinition
Dim oPoints As ObjectCollection
Set oPoints = ThisApplication.TransientObjects.CreateObjectCollection
Dim oUsedRange As Range
Set oUsedRange = oSheet.UsedRange
Dim oRowCount As Long
oRowCount = oSheet.Range("A65536").End(xlUp).Row
Dim i As Integer
For i = 1 To oRowCount
Dim strx As String, stry As String, strz As String
strx = oUsedRange.Cells(i, CInt(ColumnX.Text))
stry = oUsedRange.Cells(i, CInt(ColumnY.Text))
strz = oUsedRange.Cells(i, CInt(ColumnZ.Text))
Dim x As Double, y As Double, z As Double
x = oPartDoc.UnitsOfMeasure.GetValueFromExpression(strx, kDatabaseLengthUnits)
y = oPartDoc.UnitsOfMeasure.GetValueFromExpression(stry, kDatabaseLengthUnits)
z = oPartDoc.UnitsOfMeasure.GetValueFromExpression(strz, kDatabaseLengthUnits)
Dim oPoint As Point
Set oPoint = ThisApplication.TransientGeometry.CreatePoint(x, y, z)
Dim oWorkPoint As WorkPoint
Set oWorkPoint = oDef.WorkPoints.AddFixed(oPoint)
Call oWorkPoint.AttributeSets.Add("ImportedFromExcel").Add("Index", kIntegerType, i)
oPoints.Add oWorkPoint
Next
Dim oClientFeatures As ClientFeatures
Set oClientFeatures = oDef.Features.ClientFeatures
'Create a client feature definition by adding the selected items
Dim oClientFeatureDef As ClientFeatureDefinition
Set oClientFeatureDef = oClientFeatures.CreateDefinition("Imported Work Points", oPoints.Item(1), oPoints.Item(oPoints.Count))
Dim oCFE As ClientFeatureElement
For Each oCFE In oClientFeatureDef.ClientFeatureElements
oCFE.BrowserVisible = True
oCFE.UserEditable = True
oCFE.HighlightWithFeature = False
Next
' Create the client feature
Dim oClientFeature As ClientFeature
Set oClientFeature = oClientFeatures.Add(oClientFeatureDef, "ImportedWorkPointsClientId")
Dim oSketch3D As Sketch3D
Set oSketch3D = oDef.Sketches3D.Add
If bCreateSpline Then
Dim oSpline As SketchSpline3D
Set oSpline = oSketch3D.SketchSplines3D.Add(oPoints)
If bCloseSpline Then
oSpline.closed = True
End If
End If
If bCreatePolyline Then
For i = 1 To oPoints.Count - 1
Call oSketch3D.SketchLines3D.AddByTwoPoints(oPoints(i), oPoints(i + 1), False)
Next
If bClosePolyline Then
Call oSketch3D.SketchLines3D.AddByTwoPoints(oPoints(oPoints.Count), oPoints(1), False)
End If
End If
Set oSpline = Nothing
Set oSketch3D = Nothing
ThisApplication.UserInterfaceManager.UserInteractionDisabled = False
ThisApplication.ActiveView.Fit
Unload Me
End Sub
Private Sub CancelButton_Click()
Unload Me
ThisApplication.UserInterfaceManager.UserInteractionDisabled = False
End Sub
Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP
Foren auf CAD.de (alle Foren)
| 
