Code:
Option Explicit
Option Base 1Public oInv As Inventor.Application
Public oDrawDoc As DrawingDocument
Public oSheet As Sheet
Public oView As DrawingView
Public oWeldName As String
Public iItem As Integer
Public Sub WeldSymbol()
Set oInv = ThisApplication
If Not oInv.ActiveDocument.DocumentType = kDrawingDocumentObject Then
MsgBox "Keine Zeichnung aktiv - Exit.", vbCritical
Exit Sub
End If
Set oDrawDoc = oInv.ActiveDocument
If oDrawDoc.ActiveSheet.DrawingViews.Count = 0 Then
MsgBox "Keine Ansichten auf aktivem Blatt - Exit", vbCritical
Exit Sub
End If
Set oSheet = oDrawDoc.ActiveSheet
Dim oSelect As New clsSelect
'Dim oView As DrawingView
Set oView = oSelect.Pick(kDrawingViewFilter)
If oView Is Nothing Then Exit Sub
If Not oView.ReferencedDocumentDescriptor.ReferencedDocumentType = kAssemblyDocumentObject Then
MsgBox "Keine Ansicht einer Baugruppe gewählt - Exit.", vbCritical
Exit Sub
End If
Dim oAssDoc As AssemblyDocument
Set oAssDoc = oView.ReferencedDocumentDescriptor.ReferencedDocument
If Not TypeOf oAssDoc.ComponentDefinition Is WeldmentComponentDefinition Then
MsgBox "Keine Schweißbaugruppe - Exit", vbCritical
End If
Dim oWeldCompdef As WeldmentComponentDefinition
Set oWeldCompdef = oAssDoc.ComponentDefinition
If oWeldCompdef.Welds.Count = 0 Then
MsgBox "Keine Schweißnähte gefunden - Exit.", vbCritical
End If
CleanUp
Dim oWeld As WeldBead
Dim oWeldFace As Face
Dim oEdges As EdgeCollection
Set oEdges = oInv.TransientObjects.CreateEdgeCollection
iItem = 1
Dim j As Integer
j = 1
ReDim oContents(oWeldCompdef.Welds.Count * 2) As String
'On Error Resume Next
For Each oWeld In oWeldCompdef.Welds
oWeldName = oWeld.Name
Set oWeldFace = GetWeldFace(oWeld)
If Not oWeldFace Is Nothing Then
oContents(j) = iItem
j = j + 1
oContents(j) = oWeldName
j = j + 1
iItem = iItem + 1
End If
Next
Dim oTable As CustomTable
Set oTable = CreateTable(oContents)
End Sub
Private Function GetWeldFace(ByVal oWeld As WeldBead) As Face
Dim oWeldFace As Face
Dim oDrawingCurve As DrawingCurve
For Each oWeldFace In oWeld.BeadFaces
Set oDrawingCurve = GetDrawingCurve(oWeldFace)
If Not oDrawingCurve Is Nothing Then
Set GetWeldFace = oWeldFace
Exit Function
End If
Next
End Function
Private Function GetDrawingCurve(ByVal oWeldFace As Face) As DrawingCurve
Dim oEdge As Edge
Dim oDrawCurveEnum As DrawingCurvesEnumerator
Dim oSketchedSymbol As SketchedSymbol
Dim SketchedSymbolDef As SketchedSymbolDefinition
For Each oEdge In oWeldFace.Edges
'On Error Resume Next
Set oDrawCurveEnum = oView.DrawingCurves(oEdge)
If Not oDrawCurveEnum Is Nothing Then
If CheckSketchedSymbolDef() Is Nothing Then
Set SketchedSymbolDef = CreateSketchedSymbolDef()
Else
Set SketchedSymbolDef = CheckSketchedSymbolDef()
'Symbol an curve hängen
Set oSketchedSymbol = InsertSketchedSymbolWithLeader(oDrawCurveEnum)
If Not oSketchedSymbol Is Nothing Then
Set GetDrawingCurve = oDrawCurveEnum.Item(1)
Exit Function
End If
End If
End If
Next
End Function
Private Function CheckSketchedSymbolDef() As SketchedSymbolDefinition
Dim oSketchedSymbolDef As SketchedSymbolDefinition
For Each oSketchedSymbolDef In oDrawDoc.SketchedSymbolDefinitions
If oSketchedSymbolDef.Name = "Nahtsymbol" Then
Set CheckSketchedSymbolDef = oSketchedSymbolDef
End If
Next
End Function
Private Function CreateSketchedSymbolDef() As SketchedSymbolDefinition
' Create the new sketched symbol definition.
Dim oSketchedSymbolDef As SketchedSymbolDefinition
Call oDrawDoc.SketchedSymbolDefinitions.Add("Nahtsymbol")
Set oSketchedSymbolDef = oDrawDoc.SketchedSymbolDefinitions.Item("Nahtsymbol")
' Open the sketched symbol definition's sketch for edit. This is done by calling the Edit
' method of the SketchedSymbolDefinition to obtain a DrawingSketch. This actually creates
' a copy of the sketched symbol definition's and opens it for edit.
Dim osketch As DrawingSketch
Set osketch = oSketchedSymbolDef.Sketch
Call oSketchedSymbolDef.Edit(osketch)
Dim oTG As TransientGeometry
Set oTG = oInv.TransientGeometry
' Use the functionality of the sketch to add sketched symbol graphics.
Dim oSketchLine(0 To 5) As SketchLine
Set oSketchLine(0) = osketch.SketchLines.AddByTwoPoints(oTG.CreatePoint2d(0, 0), oTG.CreatePoint2d(0.5, 0))
Set oSketchLine(1) = osketch.SketchLines.AddByTwoPoints(oSketchLine(0).EndSketchPoint, oTG.CreatePoint2d(0.75, 0.25))
Set oSketchLine(2) = osketch.SketchLines.AddByTwoPoints(oSketchLine(1).EndSketchPoint, oTG.CreatePoint2d(0.5, 0.5))
Set oSketchLine(3) = osketch.SketchLines.AddByTwoPoints(oSketchLine(2).EndSketchPoint, oTG.CreatePoint2d(0, 0.5))
Set oSketchLine(4) = osketch.SketchLines.AddByTwoPoints(oSketchLine(3).EndSketchPoint, oTG.CreatePoint2d(-0.25, 0.25))
Set oSketchLine(5) = osketch.SketchLines.AddByTwoPoints(oSketchLine(4).EndSketchPoint, oSketchLine(0).StartSketchPoint)
' Create a point and make it the insertion point
Dim oPoint As Point2d
Set oPoint = oTG.CreatePoint2d(0.25, 0.25)
Dim oSketchPoint As SketchPoint
Set oSketchPoint = osketch.SketchPoints.Add(oPoint)
oSketchPoint.InsertionPoint = True
oSketchPoint.SketchOnly = True
' Add the two text
Dim sText As String
sText = "<Prompt ReadOnlyUniqueID='1'>Nahtnr.</Prompt>"
'sText = "Nahtnr."
Dim oTextBox As Inventor.TextBox
Set oTextBox = osketch.TextBoxes.AddFitted(oPoint, sText)
'oTextBox.SingleLineText = True
oTextBox.VerticalJustification = VerticalTextAlignmentEnum.kAlignTextMiddle
oTextBox.HorizontalJustification = HorizontalTextAlignmentEnum.kAlignTextCenter
Call oSketchedSymbolDef.ExitEdit(True)
Set CreateSketchedSymbolDef = oSketchedSymbolDef
End Function
Private Function InsertSketchedSymbolWithLeader(ByVal oDrawCurveEnum As DrawingCurvesEnumerator) As SketchedSymbol
If oDrawCurveEnum.Count = 0 Then Exit Function
' Set a reference to the drawing curve.
Dim oDrawingCurve As DrawingCurve
Set oDrawingCurve = oDrawCurveEnum.Item(1)
' Get the mid point of the selected curve
' assuming that the selection curve is linear
Dim oMidPoint As Point2d
Set oMidPoint = oDrawingCurve.MidPoint
If oMidPoint Is Nothing Then Exit Function
' Set a reference to the TransientGeometry object.
Dim oTG As TransientGeometry
Set oTG = oInv.TransientGeometry
Dim oLeaderPoints As ObjectCollection
Set oLeaderPoints = oInv.TransientObjects.CreateObjectCollection
' Create a few leader points.
Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 2, oMidPoint.Y + 2))
'Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 10, oMidPoint.Y + 5))
' Create an intent and add to the leader points collection.
' This is the geometry that the symbol will attach to.
Dim oGeometryIntent As GeometryIntent
Set oGeometryIntent = oSheet.CreateGeometryIntent(oDrawingCurve)
Call oLeaderPoints.Add(oGeometryIntent)
' Get the first symbol definition
Dim oSketchSymDef As SketchedSymbolDefinition
Set oSketchSymDef = oDrawDoc.SketchedSymbolDefinitions.Item("Nahtsymbol")
Dim sPrompt(1) As String
sPrompt(1) = iItem 'iItem & " - " & oWeldName
' Create the symbol with a leader
Set InsertSketchedSymbolWithLeader = oSheet.SketchedSymbols.AddWithLeader(oSketchSymDef, oLeaderPoints, 0, 1, sPrompt)
End Function
Private Function CreateTable(ByRef oContents() As String) As CustomTable
' Set the column titles
Dim oTitles(1 To 2) As String
oTitles(1) = "Nahtnr."
oTitles(2) = "Beschreibung"
' Set the column widths (defaults to the column title width if not specified)
Dim oColumnWidths(1 To 2) As Double
oColumnWidths(1) = 1
oColumnWidths(2) = 5.5
' Set the number of rows
Dim iRows As Integer
iRows = UBound(oContents) / 2
' Create the custom table
Dim oCustomTable As CustomTable
Set oCustomTable = oSheet.CustomTables.Add("Nahttabelle", oInv.TransientGeometry.CreatePoint2d(0, 0), 2, iRows, oTitles, oContents, oColumnWidths)
Dim oPos As Point2d
Set oPos = oInv.TransientGeometry.CreatePoint2d(1, Abs(oCustomTable.RangeBox.MinPoint.Y) + 1)
oCustomTable.Position = oPos
' Create a table format object
Dim oFormat As TableFormat
Set oFormat = oSheet.CustomTables.CreateTableFormat
' Set inside line color to red.
oFormat.InsideLineColor = oInv.TransientObjects.CreateColor(255, 0, 0)
' Modify the table formats
oCustomTable.OverrideFormat = oFormat
End Function
Private Function CleanUp()
'existierende Nahtnummernsymbole in der gewählten Ansicht suchen und löschen
'Nahtnummerntabelle löschen
Dim oSketchedSymbol As SketchedSymbol
For Each oSketchedSymbol In oSheet.SketchedSymbols
If oSketchedSymbol.Leader.AllLeafNodes.Item(1).AttachedEntity.Geometry.Parent.Name = oView.Name Then
oSketchedSymbol.Delete
End If
Next
Dim oTable As CustomTable
For Each oTable In oSheet.CustomTables
If oTable.Title = "Nahttabelle" Then oTable.Delete
Next
End Function
Foren auf CAD.de (alle Foren)
| 
) Führungslinientext oder einem eigenen skizzierten Symbol genauso funktionieren. Die anschließend auszulesen und in Tabellenform auf's Blatt zu packen sollte auch machbar sein. Könnte aber bis zum Wochenende dauern.
