---

hallo liebe CAD Gemeinde, ich finde das gebündelte fachwissen in diesem forum echt beeindruckend. vorallem die VBA-themen sind sehr interessant.

ich hab mich etwas eingelesen und stolpere aber gleich am anfang 

ich hab eine userform erstellt für 3 buttons "Ra 1,6" , "Ra 3,2" , "Ra 6,3".
und wollte erreichen das per klick ...das fenster für oberflächenangaben aufgeht und je nach bedarf schon die richtige drinn steht.

Public Sub Oberfläche()

    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    Dim oSelectSet As SelectSet
    Set oSelectSet = oDrawDoc.SelectSet
   
   
   
oDrawDoc.ActiveSheet.SurfaceTextureSymbols.Add(LeaderPionts As ObjectCollection, kMaterialRemovalProhibitedSurfaceType,[MaximumRoughness As String],kJoinOperation)

End Sub

ist zwar noch etwas wenig... aber ich möchte mich auch gerne noch selbst reindenken. also ehm wenn jemand helfen kann  dann erst mal nur die halbe wahrheit ich muss da noch was zum basteln haben

ein problem hab ich allerdings bei der MaximumRoughness wie ich da die Ra "6,3" reinbekomm.

vielen herzlichen dank 

------------------
Die Schwerkraft ist nur eine Option.

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

---

Willkommen bei CAD.DE und AUGCE!     
Vier wichtige Links für den problemlosen Einstieg:
Richtig Fragen - Nettiquette - Suchfunktion - System-Info

  

Zitat:

---

Original erstellt von Skipper1991:
... vorallem die VBA-themen sind sehr interessant. ...

---

Die VBA-Themen werden allerdings nicht in diesem Forum, sondern im IV-VBA-Forum diskutiert.

Dahin verschiebe ich jetzt auch diesen Thread.

------------------
Michael Puschner
Autodesk Inventor Certified Expert
Mensch und Maschine Scholle GmbH

[Diese Nachricht wurde von Michael Puschner am 14. Mrz. 2011 editiert.]

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

---

Hallo

2 Möglichkeiten
Entweder du schreibst den Text direkt rein

Code:

---

oDrawDoc.ActiveSheet.SurfaceTextureSymbols.Add(LeaderPionts As ObjectCollection, kMaterialRemovalProhibitedSurfaceType,"Ra 6,3",kJoinOperation)

---

oder du erstellst eine Variable

Code:

---

Dim sRoughness as String
sRoughness = "Ra 6,3"

oDrawDoc.ActiveSheet.SurfaceTextureSymbols.Add(LeaderPionts As ObjectCollection, kMaterialRemovalProhibitedSurfaceType,sRoughness,kJoinOperation)

---

Der Zugriff auf die Dialoge von Inventor ist meines Wissens nicht möglich, da nicht in die API implementiert.

------------------
MfG
RK

[Diese Nachricht wurde von rkauskh am 14. Mrz. 2011 editiert.]

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

---

danke rkauskh 

ich habs so mal probiert hat aber etwas gestockt ...
jetzt hat mein arbeitskollege ein Inventor(beispielmakro) gefunden, das oberflächenangaben einfügt wenn vorher ein maß markiert ist.
wir haben versucht es umzubasteln. Funktionieren sollte es wenn man eine modellkante in der zeichnungsableitung markiert.

viell hat da jemand eine idee dazu

Code:

---

Public Sub AddSurfaceTextureSymbol()
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Check to make sure a linear dimension is selected.
    If Not TypeOf oDrawDoc.SelectSet.Item(1) Is DrawingCurveSegment Then
        MsgBox "A linear general dimension must be selected."
        Exit Sub
    End If
   
    ' 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 oLinearDim As DrawingCurveSegment
    Set oLinearDim = oDrawDoc.SelectSet.Item(1)

    ' Get the mid point of the first extension line of the dimension
    Dim oMidPoint As Object
    Set oMidPoint = oLinearDim.EndPoint
   

    ' 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 + 0, oMidPoint.Y + 0))
    Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 0, oMidPoint.Y + 0))

    ' 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(oLinearDim, oMidPoint)

    Call oLeaderPoints.Add(oGeometryIntent)

    ' Create the symbol with a leader
   
    Dim oSymbol As SurfaceTextureSymbol
    Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, _
            kMaterialRemovalRequiredSurfaceType, _
            False, _
            False, _
            False, _
            ("Ra6.3"), _
            , , , , , _
            False)
End Sub

---

Hier hab ich noch den funktionierenden code der auf Maßhilfslinie geht

Code:

---

Public Sub AddSurfaceTextureSymbol()
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Check to make sure a linear dimension is selected.
    If Not TypeOf oDrawDoc.SelectSet.Item(1) Is LinearGeneralDimension Then
        MsgBox "A linear general dimension must be selected."
        Exit Sub
    End If
   
    ' 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 oLinearDim As LinearGeneralDimension
    Set oLinearDim = oDrawDoc.SelectSet.Item(1)

    ' Get the mid point of the first extension line of the dimension
    Dim oMidPoint As Object
    Set oMidPoint = oLinearDim.ExtensionLineTwo.MidPoint

    ' 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 + 0, oMidPoint.Y + 0))
    Call oLeaderPoints.Add(oTG.CreatePoint2d(oMidPoint.X + 0, oMidPoint.Y + 0))

    ' 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(oLinearDim, oMidPoint)

    Call oLeaderPoints.Add(oGeometryIntent)

    ' Create the symbol with a leader
   
    Dim oSymbol As SurfaceTextureSymbol
    Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, _
            kMaterialRemovalRequiredSurfaceType, _
            False, _
            False, _
            False, _
            ("Ra6.3"), _
            , , , , , _
            False)
End Sub

---

Danke lg Markus

------------------
Die Schwerkraft ist nur eine Option.

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

---

Hallo

Für Körperkanten sollte es ungefähr so gehen:

Code:

---

Public Sub AddSurfaceTextureSymbol()
    ' Set a reference to the drawing document.
    ' This assumes a drawing document is active.
    Dim oDrawDoc As DrawingDocument
    Set oDrawDoc = ThisApplication.ActiveDocument
   
    ' Check to make sure a linear dimension is selected.
    If Not TypeOf oDrawDoc.SelectSet.Item(1) Is DrawingCurveSegment Then
        MsgBox "A linear general dimension must be selected."
        Exit Sub
    End If
   
    ' 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
    Set oDCS = oDrawDoc.SelectSet.Item(1)

    ' 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, _
            False, _
            ("Ra6.3"), _
            , , , , , _
            False)
End Sub

---

------------------
MfG
RK

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

---

vielen dank
funktioniert einwandfrei...ich bedanke mich bei dir für die sehr schnelle hilfe.
hoffe. ich hab das auch mal so drauf ...

jetzt muss ich das erst mal anschaun wie du das gemacht hast.

------------------
Die Schwerkraft ist nur eine Option.

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

---

Hallo

Such mal in der Hilfe nach dem Beispiel, wie man eine Bemaßung einfügt. Dort habe ich mir das mit der Körperkante abgeguckt. 

------------------
MfG
RK

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

---

hört sich zwar blöd an aber das ist echtn tipp mit dem ich was anfangen kann  wie viel da steht

danke 

lg Skipp

------------------
Die Schwerkraft ist nur eine Option.

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

---

SurfaceTextureSymbol.png runtimeerror13.JPG

Hallo CAD Gemeinde,

tolles Macro was hier entstanden ist!!!

Ich will jedoch meine erzeugten Oberflächenzeichen auf einen bestimmten Layer legen, aber es kommt immer eine Fehlermeldung. (siehe Bild Runtime Error)
Ich denke es liegt daran, dass ich die SurfaceTextureStyle auslassen muss um den Layer definieren zu können. (siehe Bild SurfaceTextureSymbol bzw. unten stehenden Code)

Hier der gekürzte Code, der probleme macht:

Code:

---

dim sLay as string

sLay = "6x"

Dim oSymbol As SurfaceTextureSymbol
Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, sTyp, sFT, sMaj, sAAS, sMaxR, sMinR, sPM, sAPM, sSL, sASL, sLD, sMA, sAR, sSW, , sLay)

---

wenn ich die SurfaceTextureStyle und Layer weglasse funktioniert alles wunderbar:

Code:

---

Dim oSymbol As SurfaceTextureSymbol
Set oSymbol = oActiveSheet.SurfaceTextureSymbols.Add(oLeaderPoints, sTyp, sFT, sMaj, sAAS, sMaxR, sMinR, sPM, sAPM, sSL, sASL, sLD, sMA, sAR, sSW)

---

Ich hoffe jemand kann mit helfen 

Vielen Dank im voraus.

Grüße,
Joscha

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