---

Ich habe mir von hier: http://forum.cad.de/foren/ubb/Forum258/HTML/001210.shtml den Code kopiert und wollte ihn auf mehrere Kanten umschreiben leider ist mir das bis jetzt nicht geglückt )=

So sehen meine Versuche bis jetzt aus:
Ich wollte es erstmal für 2 Kanten testen aber selbst das ging leider nicht.
Habe auch schon an Stelle von DrawingCurvesEnumerator -> DrawingCurveSegment(s) versucht
Ich will es extra in ein Array speichern da ich es vorher ohne versucht hab und nach dem Platzieren des ersten Symbols hat Inventor ein leeres SelectSet ;(

Fehler: ErrNr.:91 - Desc.: Object variable or With block variable not set

Code:

---

Public Sub AddSurfaceTextureSymbol123123123aqsd()
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Set a reference to the active sheet.
    Dim oActiveSheet As Sheet
    Set oActiveSheet = oDrawDoc.ActiveSheet
   
    ' Set a reference to the drawing dimension.
    ' This assumes that a linear general dimension is selected.
    Dim oDCS As DrawingCurveSegment
  
    Dim i As Integer
    Dim SegmentArray As DrawingCurvesEnumerator 'ERROR ERROR ERROR ERROR
   
    For i = 1 To oDrawDoc.SelectSet.Count
         ' Check to make sure a linear dimension is selected.
        If Not TypeOf oDrawDoc.SelectSet.item(i) Is DrawingCurveSegment Then
            MsgBox "A linear general dimension must be selected."
            Exit Sub
        End If
        SegmentArray(i) = oDrawDoc.SelectSet.item(i)
    Next
   
    Debug.Print SegmentArray(1)
    Debug.Print SegmentArray(2)
   
    Exit Sub
    For i = 1 To oDrawDoc.SelectSet.Count
   
        ' Get the mid point of the first extension line of the dimension
        Dim oMidPoint As Point2d
        If oDCS.Parent.CurveType = kLineCurve Then
            Set oMidPoint = oDCS.Parent.MidPoint
        ElseIf oDCS.Parent.CurveType = kCircleCurve Then
            Set oMidPoint = oDCS.Parent.CenterPoint
        Else
            Set oMidPoint = oDCS.Parent.StartPoint
        End If
      
        ' Set a reference to the TransientGeometry object.
        Dim oTG As TransientGeometry
        Set oTG = ThisApplication.TransientGeometry
   
        Dim oLeaderPoints As ObjectCollection
        Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection
   
        ' Create a few leader points.
        'Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 10, oMidPoint.Y + 10))
        '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 = oActiveSheet.CreateGeometryIntent(oDCS.Parent, kMidPointIntent)
   
        Call oLeaderPoints.Add(oGeometryIntent)
   
        ' Create the symbol with a leader
        Dim oSymbol As SurfaceTextureSymbol
        Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, kMaterialRemovalRequiredSurfaceType, False, False, , ("Ra6.3"), , , , , , False)
    Next
End Sub

---

Zusätzlich würde mich noch interessieren ob es möglich ist die Oberflächen-Symbole immer "richtig" anzuordnen also auf die Kante aber nach außen und nicht in das Bauteil hinein.

------------------
Grüße aus Wien
Philipp
Email: Base64 Encoded:
cGhpcHNfOTJAeWFob28uZGU=

[Diese Nachricht wurde von axi92 am 04. Jan. 2017 editiert.]

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP

---

Habe es nun selbst hinbekommen =)

Code:

---

Function AddSurfaceTextureSymbol(sRa As String) As Boolean
    AddSurfaceTextureSymbol = False
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument

    ' Set a reference to the active sheet.
    Dim oActiveSheet As Sheet
    Set oActiveSheet = oDrawDoc.ActiveSheet

    Dim obj As Object
    For Each obj In oDrawDoc.SelectSet
        If Not TypeOf obj Is DrawingCurveSegment Then
            MsgBox "Es dürfen nur Kanten ausgewählt werden!"
            Exit Function
        End If

        ' Get the mid point of the first extension line of the dimension
        Dim oMidPoint As Point2d
        If obj.Parent.CurveType = kLineCurve Then
        Set oMidPoint = obj.Parent.MidPoint
        ElseIf obj.Parent.CurveType = kCircleCurve Then
        Set oMidPoint = obj.Parent.CenterPoint
        Else
        Set oMidPoint = obj.Parent.StartPoint
        End If

        ' Set a reference to the TransientGeometry object.
        Dim oTG As TransientGeometry
        Set oTG = ThisApplication.TransientGeometry

        Dim oLeaderPoints As ObjectCollection
        Set oLeaderPoints = ThisApplication.TransientObjects.CreateObjectCollection

        ' Create a few leader points.
        'Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 10, oMidPoint.Y + 10))
        '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 = oActiveSheet.CreateGeometryIntent(obj.Parent, kMidPointIntent)

        Call oLeaderPoints.Add(oGeometryIntent)

        ' Create the symbol with a leader
        Dim oSymbol As SurfaceTextureSymbol
        If sRa = "Ra6,4" Then
            Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, kBasicSurfaceType, False, False, , (sRa), , , , , , False)
        ElseIf sRa = "Ra25" Then
            Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, kBasicSurfaceType, False, False, , (sRa), , , , , , False)
        Else
            Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, kMaterialRemovalProhibitedSurfaceType, False, False, , , , , , , , False)
        End If
        AddSurfaceTextureSymbol = True
    Next
    Debug.Print "ErrNr.:" & Err.Number & " - Desc.: " & Err.Description
End Function

---

------------------
Grüße aus Wien
Philipp
Email: Base64 Encoded:
cGhpcHNfOTJAeWFob28uZGU=

Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP