---

Hallo allerseits eine Frage wie kann man eine gedrehte Bemaßung mit VBA neu ausrichten?
(bzw griffe bearbeiten?)
zb anklicken und den x wert ändern?? geht dies ohne LISP?

Mfg Chris

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

---

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

---

Ja danke erstmal aber das ist für die falsche Bemaßung
Ich müßte wissen wie man
AcDbRotatedDimension
verändert??

Mfg Chris

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

---

obj.gif

Hallo Chris,

meinst du es so ?

Code:

---

If obj.ObjectName = "AcDbRotatedDimension" Then
    obj.TextRotation = obj.TextRotation + 20

    obj.Update
End If

---

Wilfried Stelberg

[Edit: zuerst falsch gelesen  ]
------------------
Warum lisp'eln wenn's auch anders geht. 
www.ib-stelberg.de

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

---

Hm wie ich den Text alleine verschiebe und drehe weiß ich ja aber wie verändert man die lage der Linien, Hilfslinien?

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

---

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

---

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

---

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

---

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 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)
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

---

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

---

Warum wird der Handle verändert? bzw.
woher weiß man daß man den Handle so verändern muß??
Hast du da ne Ahnung??? Carsten??
Gibts dazu irgendwelche Infos??

Mfg Chris

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