| | | Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte | | | | PNY präsentiert die neue NVIDIA RTX A400 und die A1000 Grafikkarte, eine Pressemitteilung
|
Autor
|
Thema: VBA Makro Oberflächenangabe (3301 mal gelesen)
|
Skipper1991 Mitglied Technischer Zeichner
Beiträge: 6 Registriert: 14.03.2011 Inv 2011 Markus S.
|
erstellt am: 14. Mrz. 2011 15:47 <-- editieren / zitieren --> Unities abgeben:
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 |
Michael Puschner Ehrenmitglied V.I.P. h.c. Rentner
Beiträge: 13006 Registriert: 29.08.2003
|
erstellt am: 14. Mrz. 2011 19:30 <-- editieren / zitieren --> Unities abgeben: Nur für Skipper1991
|
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2580 Registriert: 15.11.2006 Windows 10 x64, AIP 2020-2025
|
erstellt am: 14. Mrz. 2011 22:19 <-- editieren / zitieren --> Unities abgeben: Nur für Skipper1991
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 |
Skipper1991 Mitglied Technischer Zeichner
Beiträge: 6 Registriert: 14.03.2011 Inv 2011 Markus S.
|
erstellt am: 15. Mrz. 2011 13:10 <-- editieren / zitieren --> Unities abgeben:
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 |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2580 Registriert: 15.11.2006 Windows 10 x64, AIP 2020-2025
|
erstellt am: 15. Mrz. 2011 14:48 <-- editieren / zitieren --> Unities abgeben: Nur für Skipper1991
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 |
Skipper1991 Mitglied Technischer Zeichner
Beiträge: 6 Registriert: 14.03.2011 Inv 2011 Markus S.
|
erstellt am: 15. Mrz. 2011 16:18 <-- editieren / zitieren --> Unities abgeben:
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 |
rkauskh Moderator Dipl.-Ing. (FH) Versorgungstechnik
Beiträge: 2580 Registriert: 15.11.2006 Windows 10 x64, AIP 2020-2025
|
erstellt am: 15. Mrz. 2011 20:48 <-- editieren / zitieren --> Unities abgeben: Nur für Skipper1991
|
Skipper1991 Mitglied Technischer Zeichner
Beiträge: 6 Registriert: 14.03.2011 Inv 2011 Markus S.
|
erstellt am: 16. Mrz. 2011 07:46 <-- editieren / zitieren --> Unities abgeben:
|
KAME-WJ Mitglied Maschinenbau-Ingenieur
Beiträge: 22 Registriert: 22.09.2014 Intel Core i9-9900KF, 8-Core @5GHz 16 GB DDR4-2666 MHz NVIDIA Quadro P1000, 4GB GDDR5 ASUS Prime Z390-P WIN10 x64 auf NVME SSD INV2019
|
erstellt am: 20. Okt. 2014 15:44 <-- editieren / zitieren --> Unities abgeben: Nur für Skipper1991
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 stringsLay = "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 |
| Anzeige.:
Anzeige: (Infos zum Werbeplatz >>)
|