| |
| Gut zu wissen: Hilfreiche Tipps und Tricks aus der Praxis prägnant, und auf den Punkt gebracht für Autodesk Produkte |
| |
| PNY bietet das umfangreichste Ökosystem von B2B als auch B2C-Lösungen für IT-Akteure auf dem Markt, eine Pressemitteilung
|
Autor
|
Thema: Gedrehte Bemaßung ausrichten (2237 mal gelesen)
|
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 16. Aug. 2007 07:58 <-- editieren / zitieren --> Unities abgeben:
|
Headcase Mitglied Dipl.-Ing. (FH) --> Maschinenbau
Beiträge: 141 Registriert: 14.10.2004 WinXP Prof., SP3 AutoCAD Mechanical 2010 (2008) Inventor 2010 (2008)
|
erstellt am: 17. Aug. 2007 09:36 <-- editieren / zitieren --> Unities abgeben: Nur für c.schojer
Hallo! Wenn ich die Frage richtig verstanden habe, soll durch klicken eine Bemaßung gewählt werden und der Ursprungspunkt der Hilfslinien in x-Richtung verschoben werden? Via VBA würde das etwa so aussehen:
Code:
Dim obj As AcadObject Dim pp(0 To 2) As Double Dim pkt1 As Variant ThisDrawing.Utility.GetEntity obj, pp, "Bemaßung wählen"If obj.ObjectName = "AcDbAlignedDimension" Then pkt1 = obj.ExtLine1Point pkt1(0) = pkt1(0) + 10 obj.ExtLine1Point = pkt1 obj.Update End If
Edit: Um den Maßtext zu verschieben (was sicherlich sinnvoller wäre), einfach diesen Code in der If-Anweisung verwenden:Code:
pkt1 = obj.TextPosition pkt1(0) = pkt1(0) + 10 obj.TextPosition = pkt1 obj.Update
Grüße! René[Diese Nachricht wurde von Headcase am 17. Aug. 2007 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 17. Aug. 2007 19:43 <-- editieren / zitieren --> Unities abgeben:
|
Stelli1 Moderator Verm.-Ing.
Beiträge: 1526 Registriert: 17.08.2005 Map 2000-2014, Rasterdesign, MapGuide, Autodesk Topobase, VS6, VS.net 2013
|
erstellt am: 17. Aug. 2007 20:33 <-- editieren / zitieren --> Unities abgeben: Nur für c.schojer
|
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 17. Aug. 2007 22:59 <-- editieren / zitieren --> Unities abgeben:
|
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 29. Aug. 2007 16:45 <-- editieren / zitieren --> Unities abgeben:
Weiß niemand wie man die ganze bemaßung ausrichten kann?? (Mit vba)?? geht dies bei dem Bemaßungstyp (AcDbRotatedDimension) nicht?? Mfg Chris [Diese Nachricht wurde von c.schojer am 29. Aug. 2007 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Carsten1210 Mitglied staatl. geprüfter Holztechniker
Beiträge: 1358 Registriert: 24.07.2002
|
erstellt am: 29. Aug. 2007 18:32 <-- editieren / zitieren --> Unities abgeben: Nur für c.schojer
Hi Chris, Mit VBA vorhandene Bemassungen ändern ist im AutoCAD ziemlich eingeschränkt. Warum liest du die die Definitionspunkte der Bemassung aus und erstellst einfach ein neue. Die alte kannst du dann ja löschen. Das wäre, so meine ich, der einfachste Weg um das Problem zu lösen. Edit: Schau dir doch die Möglichkeiten im Objekt-Explorer mal an. (F2 in der IDE drücken) Gruß, Carstem [Diese Nachricht wurde von Carsten1210 am 29. Aug. 2007 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 30. Aug. 2007 10:17 <-- editieren / zitieren --> Unities abgeben:
Das ist ja gerade das Problem ich weiß nicht wie ich die Punkte von AcadDimRotated bekomme? Weißt du wies geht?? Wie ich sie erzeuge weiß ich, aber wie bekomme ich die Punkte wieder zurück? Sehe im Debugger nirgends ein Array mit Punktangaben. Mfg Chris Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
Carsten1210 Mitglied staatl. geprüfter Holztechniker
Beiträge: 1358 Registriert: 24.07.2002
|
erstellt am: 30. Aug. 2007 10:22 <-- editieren / zitieren --> Unities abgeben: Nur für c.schojer
Hi Chris, Hier ein Code, den ich irgendwo im Netz mal gefunden habe: Code: Public Sub DimPts() Dim objDim0 As AcadDimension Dim objDimDefBlk As AcadBlock Dim varPickPt As Variant Dim varDimLdrSPt As Variant Dim varDimLdrEpt As Variant Dim varDimTxtPt As Variant Dim intCntr As Integer intCntr = 0 Dim intCntr2 As Integer intCntr2 = 0 Dim objTestEntity As AcadEntity Dim objTestPt As AcadPoint Dim strMessage As StringThisDrawing.Utility.GetEntity objDim0, varPickPt, "Select dimension: " If objDim0 Is Nothing Then MsgBox "You failed to pick a dimension object", vbCritical Exit Sub ElseIf TypeOf objDim0 Is AcadDimension Then Set objDimDefBlk = GetDefinition(objDim0.Handle) For intCntr = 0 To objDimDefBlk.Count - 1 Set objTestEntity = objDimDefBlk(intCntr) If TypeOf objTestEntity Is AcadPoint Then Set objTestPt = objTestEntity Select Case intCntr2 Case 0 varDimLdrSPt = objTestPt.Coordinates intCntr2 = intCntr2 + 1 Case 1 varDimLdrEpt = objTestPt.Coordinates intCntr2 = intCntr2 + 1 Case 2 varDimTxtPt = objTestPt.Coordinates intCntr2 = intCntr2 + 1 End Select End If Next MsgBox "Start Point = " & varDimLdrSPt(0) & " , " & varDimLdrSPt(1) & vbCrLf & _ "End Point = " & varDimLdrEpt(0) & " , " & varDimLdrEpt(1) End If End Sub Function GetDefinition(strHandle As String) As AcadBlock ' Returns a dimension's controlling block Dim objBlk As AcadBlock Dim strLeft As String Dim strRight As String Dim blnTest As Boolean On Error GoTo Err_Control strLeft = Left(strHandle, Len(strHandle) - 2) strRight = "&H" & Right(strHandle, 2) strRight = strRight + 1 strHandle = strLeft & Hex(strRight) blnTest = True Set objBlk = ThisDrawing.HandleToObject(strHandle) Set GetDefinition = objBlk Exit_Here: Exit Function Err_Control: Select Case Err.Number Case 13 'Type Mismatch If blnTest Then strRight = strRight + 1 strHandle = strLeft & Hex(strRight) Err.Clear 'single increment only! Reset test blnTest = Not blnTest Resume Else 'second time in or other mismatch Err.Raise Err.Number, Err.Source, Err.Description, _ Err.HelpFile, Err.HelpContext End If Case -2147467259 Err.Clear MsgBox "Invalid dimension entity...", vbCritical End Case Else Err.Raise Err.Number, Err.Source, Err.Description, _ Err.HelpFile, Err.HelpContext End Select End Function
Damit kannst du die Basis-Punkte von Bemassungen ermitteln. Gruß, Carsten Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 30. Aug. 2007 10:33 <-- editieren / zitieren --> Unities abgeben:
Vielen dank hab schon selbst lange gesucht aber nix gefunden !!!!!!!!!!!!!!! So hab ein ganz einfaches programm geschrieben wo man nun auch alles andere verschieben kann unter verwendung des Source Codes den du mir gegeben hast. Habe ein wenig gebraucht um herauszufinden was der Code macht Eine Bemaßung ist sozusagen nix anderes als ein Block den man bearbeiten kann. Man müßte an den Code noch feilen aber ich denke so kann ichs lösen. Gibts ne Möglichkeit ein regenerieren zu vermeiden?? und trotzdem das ergebnis zu sehen?? (object.update zeigt keine Wirkung) Die Funktion "GetDefinition" hast eh oben bleibt wie gehabt!
Public Sub Move_Dimlinear() Dim objDim0 As AcadDimension Dim objDimDefBlk As AcadBlock Dim varPickPt As Variant Dim varDimLdrSPt As Variant Dim varDimLdrEpt As Variant Dim varDimTxtPt As Variant, a Dim intCntr As Integer Dim StartpointU, EndPointU, DeltaX, DeltaY, DeltaZ Dim Koordinaten DeltaX = 0 DeltaY = -10 DeltaZ = 0
intCntr = 0 Dim intCntr2 As Integer intCntr2 = 0 Dim objTestEntity As AcadEntity Dim objTest Dim strMessage As String ThisDrawing.Utility.GetEntity objDim0, varPickPt, "Select dimension: " If objDim0 Is Nothing Then MsgBox "You failed to pick a dimension object", vbCritical Exit Sub ElseIf TypeOf objDim0 Is AcadDimension Then Set objDimDefBlk = GetDefinition(objDim0.Handle) For intCntr = 0 To objDimDefBlk.count - 1 Set objTestEntity = objDimDefBlk(intCntr) Debug.Print objTestEntity.Objectname If TypeOf objTestEntity Is AcadMText Then Set objTest = objTestEntity Koordinaten = objTest.insertionPoint Koordinaten(0) = Koordinaten(0) + DeltaX Koordinaten(1) = Koordinaten(1) + DeltaY Koordinaten(2) = Koordinaten(2) + DeltaZ objTest.insertionPoint = Koordinaten End If If TypeOf objTestEntity Is AcadSolid Then Set objTest = objTestEntity Koordinaten = objTest.Coordinates For a = 0 To UBound(Koordinaten) Step 3 Koordinaten(a) = Koordinaten(a) + DeltaX Koordinaten(a + 1) = Koordinaten(a + 1) + DeltaY Koordinaten(a + 2) = Koordinaten(a + 2) + DeltaZ Next a objTest.Coordinates = Koordinaten End If If TypeOf objTestEntity Is AcadLine Then 'AcadPoint Then Set objTest = objTestEntity Startpoint = objTest.Startpoint EndPoint = objTest.EndPoint Startpoint(0) = Startpoint(0) + DeltaX Startpoint(1) = Startpoint(1) + DeltaY Startpoint(2) = Startpoint(2) + DeltaZ EndPoint(0) = EndPoint(0) + DeltaX EndPoint(1) = EndPoint(1) + DeltaY EndPoint(2) = EndPoint(2) + DeltaZ objTest.Startpoint = Startpoint objTest.EndPoint = EndPoint End If Next End If ThisDrawing.Regen acActiveViewport End Sub
[Diese Nachricht wurde von c.schojer am 30. Aug. 2007 editiert.] Eine Antwort auf diesen Beitrag verfassen (mit Zitat/Zitat des Beitrags) IP |
c.schojer Mitglied
Beiträge: 299 Registriert: 23.05.2007 Autocad 2018
|
erstellt am: 31. Aug. 2007 07:08 <-- editieren / zitieren --> Unities abgeben:
|