Entschuldigung wenn ich mich jetzt einfach mal einklinke aber ich bräuchte so etwas ähnliches. Ich suche einen Code, der mir den Aktuellen Versatz (Translation und Rotation) in Excel ausgeben kann.
Sub Export_xyz_excel()
Dim oAsmDoc As AssemblyDocument
Set oAsmDoc = ThisApplication.ActiveDocument
Dim sDocName As String
Dim i As Long
Dim iRow As Long
Dim XL As Object
Dim xlWB As Object
Dim xlWS As Object
If ThisApplication.ActiveDocumentType <> kAssemblyDocumentObject And ThisApplication.ActiveDocumentType <> kPartDocumentObject Then
MsgBox "Only Part or Assymbly document ", vbCritical
Exit Sub
End If
Set XL = CreateObject("Excel.Application")
Set xlWB = XL.Workbooks.Add
Set xlWS = xlWB.ActiveSheet
XL.Visible = True
iRow = 1
xlWS.Cells(iRow, 1).value = "Name"
xlWS.Cells(iRow, 2).value = "Type"
xlWS.Cells(iRow, 3).value = "Child"
xlWS.Cells(iRow, 4).value = "Length"
xlWS.Cells(iRow, 5).value = "Width"
xlWS.Cells(iRow, 6).value = "WidthOfLift"
xlWS.Cells(iRow, 7).value = "LiftRelPosX"
xlWS.Cells(iRow, 8).value = "Height"
xlWS.Cells(iRow, 9).value = "PosX"
xlWS.Cells(iRow, 10).value = "PosY"
xlWS.Cells(iRow, 11).value = "PosZ"
xlWS.Cells(iRow, 12).value = "RotX "
xlWS.Cells(iRow, 13).value = "RotY "
xlWS.Cells(iRow, 14).value = "RotZ "
xlWS.Rows("1:1").Select
XL.Selection.Font.Bold = True
With XL.Selection.Font
.name = " Arial"
.Size = 11
.Bold = False
End With
On Error Resume Next
For i = 1 To ThisApplication.ActiveDocument.ComponentDefinition.Occurrences.Count
Dim oOcc As ComponentOccurrence
Set oOcc = ThisApplication.ActiveDocument.ComponentDefinition.Occurrences(i)
Dim oOL As Vector
Dim oT As Matrix
Set oT = oOcc.Transformation
Set oOL = oT.Translation
Dim oMatrix1 As Matrix
Set oMatrix1 = oOcc.Transformation
Dim oOrigin1 As Point
Dim oX1 As Vector
Dim oY1 As Vector
Dim oZ1 As Vector
Call oMatrix1.GetCoordinateSystem(oOrigin1, oX1, oY1, oZ1)
Dim oMatrix2 As Matrix
Set oMatrix2 = ThisApplication.TransientGeometry.CreateMatrix
Dim oOrigin2 As Point
Dim oX2 As Vector
Dim oY2 As Vector
Dim oZ2 As Vector
Call oMatrix2.GetCoordinateSystem(oOrigin2, oX2, oY2, oZ2)
Dim paraLänge As Object
Dim paraAbstand As Object
Dim paraQuer As Object
Dim paraFuss As Object
Dim paraHöhe As Object
Dim oParameter As Object
Dim paraType As Object
Dim k As Long
Set paraLänge = oAsmDoc.ComponentDefinition.Occurrences.Item(i).Definition.Parameters.Item("Segmentlänge")
Set paraQuer = oAsmDoc.ComponentDefinition.Occurrences.Item(i).Definition.Parameters.Item("Anzahl_Querstreben")
Set paraFuss = oAsmDoc.ComponentDefinition.Occurrences.Item(i).Definition.Parameters.Item("Anzahl_Standfüße")
Set paraHöhe = oAsmDoc.ComponentDefinition.Occurrences.Item(i).Definition.Parameters.Item("Eingabe_Höhe")
Set paraAbstand = oAsmDoc.ComponentDefinition.Occurrences.Item(i).Definition.Parameters.Item("Abstand_Kettenmitte")
iRow = iRow + 1
Debug.Print
xlWS.Cells(iRow, 1).value = oOcc.name
xlWS.Cells(iRow, 3).value = 0
xlWS.Cells(iRow, 4).value = paraLänge.value
xlWS.Cells(iRow, 4).value = Round(xlWS.Cells(iRow, 4).value / 100, 3)
xlWS.Cells(iRow, 5).value = paraAbstand.value
xlWS.Cells(iRow, 5).value = Round(xlWS.Cells(iRow, 5).value / 100, 3)
xlWS.Cells(iRow, 6).value = 0
xlWS.Cells(iRow, 7).value = 0
xlWS.Cells(iRow, 8).value = paraHöhe.value
xlWS.Cells(iRow, 8).value = Round(xlWS.Cells(iRow, 8).value / 100, 3)
xlWS.Cells(iRow, 9).value = oOL.x
xlWS.Cells(iRow, 9).value = Round(xlWS.Cells(iRow, 9).value / 100 * -1, 3)
xlWS.Cells(iRow, 10).value = paraHöhe.value
xlWS.Cells(iRow, 10).value = Round(xlWS.Cells(iRow, 10).value / 100, 3)
xlWS.Cells(iRow, 11).value = oOL.y
xlWS.Cells(iRow, 11).value = Round(xlWS.Cells(iRow, 11).value / 100, 3)
xlWS.Cells(iRow, 13).value = Round((oY1.AngleTo(oY2) * 180) / 3.14159265 - 90, 0)
Next
XL.Cells.Select
XL.Cells.EntireColumn.AutoFit
xlWS.Range("A1").Select
sDocName = ThisApplication.ActiveDocument.FullFileName
If sDocName = "" Then
sDocName = "c:\temp\x"
Else
sDocName = Mid(sDocName, 1, Len(sDocName) - 4)
End If
If Dir(sDocName & ".xls") <> "" Then
i = 1
Do While Dir(sDocName & "_" & i & ".xls") <> ""
i = i + 1
Loop
sDocName = sDocName & "_" & i
End If
xlWB.SaveAs FileName:=sDocName
Set xlWS = Nothing
Set xlWB = Nothing
Set XL = Nothing
End Sub
Das habe ich mir mal so zusammenkopiert. Es funktioniert auch Teilweise aber noch nicht komplett. Hier wird sozusagen der Winkel zwischen zwei Vektoren bestimmt. Hätte da jemand eine "schönere" Idee also ich weiß, dass Inventor mit Matrixen arbeitet aber leider weiß ich nicht wie ich mir diese ausgeben lassen kann.
Vielen Dank und freundliche Grüße
Valentin
