---

Hallo nochmals !
Folgendes Problem ich habe zb eine Bemaßung lagemäßig geändert

Siehe Beispiel
grafisch wirds richtig angezeigt aber wie kann man die Griffe der Bemaßung mitändern!?!?
Die sind dann immer noch da wo sie vorher waren!!

Mfg Chris

*********************
Sub Bemaßung_in_y_Ausrichten()
Dim a, b, c, p1, p2
Dim SSETGLOK
Call Autocad_Tools.InitSset

Set SSETGLOK = Autocad_Tools.SSETG
If VarType(SSETGLOK) = vbEmpty Then
Exit Sub
End If

p1 = ThisDrawing.Utility.GetPoint(, "Move from Point: " & VBA.Chr(13))

p2 = ThisDrawing.Utility.GetPoint(, "to Point: " & VBA.Chr(13))

If VarType(p1) <> vbEmpty And VarType(p2) <> vbEmpty Then

a = p2(1) - p1(1)
Call Move_Dimlinear(0, a, 0, SSETGLOK)

End If

End Sub

Public Sub Move_Dimlinear(DELTAX, DELTAY, DELTAZ, SSetL)
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 StartPoint, EndPoint
Dim Koordinaten, SS
'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: "

For Each objDim0 In SSetL
Debug.Print objDim0.Objectname

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 AcadPoint Then
        Set objTest = objTestEntity
        Koordinaten = objTest.Coordinates
        Koordinaten(0) = Koordinaten(0) + DELTAX
        Koordinaten(1) = Koordinaten(1) + DELTAY
        Koordinaten(2) = Koordinaten(2) + DELTAZ
        objTest.Coordinates = Koordinaten
   
    End If
   
   
   
   
    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 AcadBlockReference 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

Next objDim0

ThisDrawing.Regen acActiveViewport

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 = VBA.Left(strHandle, VBA.Len(strHandle) - 2)
strRight = "&H" & VBA.Right(strHandle, 2)
strRight = strRight + 1
strHandle = strLeft & VBA.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 & VBA.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

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

---

Hi,

So wie ich das sehe, werden von deinem Makro nur die grafischen Elemente der Bemassung geändert. Die Bezugspunkte bleiben aber gleich. Wenn du nun ein BemObj.Update machst werden die grafischen Elemente wieder an die Griff-Punkte gesetzt. Daher wird es in VBA nur die Möglichkeit geben, die Bezugspunkte der Bemassung zu ermitteln und diese dann neu zu erstellen und die alte löschen.

Gruß, Carsten

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

---

Die Frage ist ja eben ob man nicht nur die Grafischen Elemente sondern auch die Griffe in VBA ändern kann weißt du da ne Möglichkeit carsten???
Mfg Chris

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

---

Hi,

Ich kenne keine Möglichkeit, in VBA die Definition der Bezugspunkte / Griffe zu ändern. Ich denke, das du dort nicht drum rum kommst die Bemassung mit den Änderungen neu zu erstellen. Hab mich aber nicht wirklich mit dem Thema auseinander gesetzt.

Gruß, Carsten

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

---

Hey Carsten
ich bekomme manchal nen Fehler in
der Function GetDefinition!
Unbekannte Referenz??
oder Invalid Dimension Entity obwohl eine Bemaßung angeklickt wurde??!

Weißt du was das sein könnte??
Mfg Chris

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

---

Hi Chris,

Kannst du den Fehler eingrenzen, wobei er auftritt?!
Ich nutze die Funktion selber nicht, daher wäre nicht schlecht, wenn du feststellen könntest wo der Fehler auftritt.

Gruß, Carsten

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

---

Der Handle ist 10A
bei
Set objBlk = ThisDrawing.HandleToObject(strHandle)
bei objBlk steht Nothing drinnen

dh HandleTo Object geht nicht!?!

dann springt er zu

Select Case Err.Number
und dann weiter zu dem Unbekannten Fehler

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 = VBA.Left(strHandle, VBA.Len(strHandle) - 2)
strRight = "&H" & VBA.Right(strHandle, 2)
strRight = strRight + 1
strHandle = strLeft & VBA.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 & VBA.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
Debug.Print Err.Description

Hier unten steigt er aus!

Err.Raise Err.Number, Err.Source, Err.Description, _
Err.HelpFile, Err.HelpContext

End Select
End Function

Wie Funktioniert das mit dem Handle Zerlegen??
Gibts dazu irgendwelche Information??

MFG Chris

[Diese Nachricht wurde von c.schojer am 20. Okt. 2007 editiert.]

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

---

Hat sich nun Erledigt hab nen Anderen Code im Netz gefunden bei dem das sehr gut funktioniert!!

Option Explicit

'Test function to find the block of the dimension
Sub test()
Dim ent As AcadEntity
Dim pt As Variant
Dim blk As AcadBlock
ThisDrawing.Utility.GetEntity ent, pt, "Select dimension"
If TypeOf ent Is AcadDimension Then
Set blk = getdimblock(ent)
MsgBox "Dimension block is" & blk.Name
Else
MsgBox "Dimension not selected"
End If
End Sub

'returns a number conversion of a handle string
Private Function handnum(hand As String) As Single
handnum = CSng("&H" & hand)
End Function

'Function to return the dimension block of a dimension object
Public Function getdimblock(dimen) As AcadBlock 'As AcadDimension) As AcadBlock
Dim nexthand As String
Dim doc As AcadDocument
Set doc = dimen.Document
nexthand = VBA.Hex(handnum(dimen.handle) + 1)
On Error Resume Next
Set getdimblock = doc.HandleToObject(nexthand)
Err.Clear
While getdimblock Is Nothing Or Not TypeOf getdimblock Is AcadBlock
nexthand = VBA.Hex(handnum(nexthand) + 1)
On Error Resume Next
Set getdimblock = doc.HandleToObject(nexthand)
Err.Clear
Wend
End Function

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