---

Hallo zusammen.

Ich möchte gerne eine vorhandene Bemassung mittels VBA ändern. Um genau zu sein die Dezimalstellen eins rauf oder runter. Folgender Code habe ich mir ausgedacht. Leider funktioniert der nicht richtig bzw. es wird an der Bemassung nichts geändert:

Sub EinheitErhöhen()
    Dim BemDezi As Integer, AktuellBem As AcadDimStyle
    Dim DimObj As AcadDimRotated
    Dim Punkt(2) As Double, BemStilName As String
   
    On Error GoTo ErrZeile
    ThisDrawing.Utility.GetEntity DimObj, Punkt, "Bemassung wählen: "
    BemStilName = DimObj.StyleName
   
    BemDezi = ThisDrawing.GetVariable("DIMDEC") + 1
    ThisDrawing.SetVariable "DIMDEC", BemDezi
   
    DimObj.StyleName = BemStilName
    DimObj.Update
   
    Exit Sub
ErrZeile:
    Select Case Err.Number
        Case 13
            MsgBox "Keine Bemassung ausgewählt!", vbOKOnly, "M&P"
        Case Else
            MsgBox "ErrorCode: " & Err.Number & vbCr & Err.Description
    End Select
End Sub

Jeder Bemassung sind doch mehr oder weniger vom aktuellen BemStil abweichende Einstellungen hinterlegt. Wie kann ich diese per VBA abrufen und/oder ändern? In der Hilfe steht nur:
Die Einstellungen für einen Bemaßungsstil legen Sie mit Hilfe der Bemaßungs-Systemvariablen fest.
und
Um den Stil einer vorhandenen Bemaßung zu ändern, wenden Sie die StyleName-Eigenschaft auf die entsprechende Bemaßung an.

Kann mir jemand weiterhelfen?

Gruß
Tomi

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

---

Als Anregung guck mal hier

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

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

---

Leider hilft mir das gar nicht weiter. Dort geht es um krumme Maße zu begradigen. Ich habe schon grade Maße. Nur manche brauchen (vor allem, wenn diese in Metern dargestellt werden) eine Dezi-Stelle mehr z.B. 3.25 in 3.245.

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

---

dann nimm dies ( auch wenn es Lisp ist)
(defun PUTPRECISION(Precision / BLOCK )
  (vl-load-com)
  (vlax-for LAYOUT (vla-get-layouts(vla-get-activedocument(vlax-get-acad-object)))
    (vlax-for ITEM (setq BLOCK (vla-get-Block LAYOUT))
      (if(wcmatch (strcase"AcDbRotatedDimension") "*DIMENSION*")
        (vl-catch-all-error-p
          (vl-catch-all-apply
            'vla-put-PrimaryUnitsPrecision
            (list ITEM Precision)
          )
        )
      )
    )
  )
  (vla-regen(vla-get-activedocument (vlax-get-acad-object)) acAllViewports)
)

der Aufruf in der Befehlszeile
(PUTPRECISION 3)
stellt dir 3 Dezimalstellen als Genauigkeit bei allen Bemassungen ein

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

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

---

Das Programm funktioniert nicht. Habe die Zeilen im VisualLisp reinkopiert und wie du geschrieben hast den Kommandobefehl ausgeführt.
Das Programm meldet nur *Abbruch*.
Über Lisp ist zwar auch eine Lösung aber ich hätte das Problem lieber in VBA gelöst.
Trotzdem Danke.

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

---

Wie man ein Lisp lädt, findest du hier ... in VBA ist es aber das gleiche Prinzip, d.h. Zugriff auf die ActivX-Methoden

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

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

---

Bevor ich mit VBA angefangen habe, programmierte ich in Lisp. Ich glaube nicht, daß ich eine Anleitung brauche, wie ich solche Programme zum laufen bekomme  
Lisp erkennt die Befehle vl-load-com und vla-get-block und einige andere nicht. Keine Ahnung warum. Die werden in meinem Editor auch nicht als bekannte Befehle farbig gekennzeichnet.
Vielleicht doch lieber eine Lösung in VBA?

[Diese Nachricht wurde von TomiProg am 02. Dez. 2004 editiert.]

[Diese Nachricht wurde von TomiProg am 02. Dez. 2004 editiert.]

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

---

nach
Zitat..
Habe die Zeilen im VisualLisp reinkopiert und wie du geschrieben hast den Kommandobefehl ausgeführt.

hielt ich meinen Ladehinweis für angebracht

sorry .. sehe gerade, das du mit ACAD14 arbeitest...

und da gabs den vlisp-editor? und Activx wurde nicht unterstützt .. ??

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

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

---

Ja. Das ist ein externes Progamm von Mensch und Maschine. Hat damals einige Mark gekostet. Aber ActiveX ist auch dabei. Aber wahrscheinlich sind nicht alle Befehle dabei, die heute im Vlisp-Editor vorhanden sind 

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

---

unter R14 gabs den Visual lisp Editor als englische Installation
es war damit möglich schon eine Menge Visual lisp Befehle zu nutzen. Dazu musste aber der Kot als arx kompiliert werden, somit wurde der gesamte Interpreter mit einkompiliert. Deshalb waren die arx'e auch immer so Groß im Verhältniss zum lisp.

Also entweder Lisp pur oder besorg dir den VLisp-Editor für R14

------------------
Gruß
CADwiesel
Besucht uns im CHAT

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

---

Den VLisp Editor habe ich ja. Auch wenn ich die obigen Zeile in ARX kompiliere ergibt es kein besseres Ergebnis. Und das mit der Größe ist auch ein Grund, warum ich lieber in VBA programmiere.

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

---

na, wenn du den hast, dan debugge den code doch einfach - da siehsde doch wo der Fehler ist

------------------
Gruß
CADwiesel
Besucht uns im CHAT

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

---

Wie Witzig. Das habe ich doch oben erklärt, daß dies keinen Erfolg hatte. Er kennt die Befehle auch im debuggten Zustand (Datei mit ARX-Endung) nicht. Mit Lisp ist dies wohl nicht zu lösen.

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

---

dann mach das so ( obwohl ich überhaupt keinen blassen von VBA habe):

ThisDrawing.Utility.GetEntity DimObj, Punkt, "Bemassung wählen: "
DimObj.PrimaryUnitsPrecision=3

------------------
- Thomas -
"Bei 99% aller Probleme ist die umfassende Beschreibung des Problems bereits mehr als die Hälfte der Lösung desselben."

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

---

vielleicht liegt es ja daran, dass es im R14 noch gar kein Layout gibt? (oder gab es das dort auch schon?)

Ansonsten nehme ich an, dass die im R14 vorhandene ActiveX-Schnittstelle diese Eigenschaften und Methoden noch nicht unterstützt.

Grüße Holger

------------------
Holger Brischke
(defun - Lisp over night!                          Autodesk User Group Central Europe
AutoLISP-Programmierung für AutoCAD              AUGCE Manager Deutschland
Da weiß man, wann man's hat!
                     

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

---

Zitat:

---

Original erstellt von CADmium:
dann mach das so ( obwohl ich überhaupt keinen blassen von VBA habe):

ThisDrawing.Utility.GetEntity DimObj, Punkt, "Bemassung wählen: "
DimObj.PrimaryUnitsPrecision=3

---

Wäre schön, wenn die Methode funktionieren würde. Tut es leider nicht. Verdamt sei R14  
Da hat Brischke leider Recht, daß all die schönen Dinge mit R14 nicht gehen. Um bessere Arbeitsbedingungen zu bekommen, muß ich wohl meine Arbeitsstelle wechseln 

[Diese Nachricht wurde von TomiProg am 02. Dez. 2004 editiert.]

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

---

Ich hab' irgendwie das Gefühl, dass hier mal aufgeräumt werden muss;-)

Zunächst mal, Tomi: Lass dich nicht verwirren, einige Antworten waren nicht sehr sachdienlich. Weder geht es hier um Lisp, noch um Layouts...

Dein Problem liegt wo ganz anders: Das Programm sieht aus, als sei es für eine noch ältere AutoCAD-Version geschrieben. Da war es tatsächlich so, dass man nur eine Variable wie DIMDEC ändern musste. Ein anschliessendes Update der Bemassungen hat diese dann verändert, es sei denn, es war ein Bemstil gegeben. Das hat regelmäßig ganze Zeichnungen versaut, wenn ohne Bemstil bemaßt wurde. Deswegen wurde das Konzept der Overrides eingeführt - d.h. die Bemaßungsvariablen im Speicher wirken sich nur bei neuen Bemaßungen aus, aber nicht beim Updaten.

Code:

---

    BemStilName = DimObj.StyleName
   
    BemDezi = ThisDrawing.GetVariable("DIMDEC") + 1
    ThisDrawing.SetVariable "DIMDEC", BemDezi
   
    DimObj.StyleName = BemStilName
    DimObj.Update

---

Das macht so keinen Sinn. Du liest den Bemstil der Bemassung aus und weist ihn hier etwas später wieder zu - ohne dass sich zwischendurch was geändert hätte. Hast du eine Zeile vergessen, die den Stil der Bemaßung auf "keiner" setzt? Oder aber fehlt irgendwas wie DimObj.PrimaryUnitsPrecision = acDimPrecisionFour(...Five,...Six,...)?

Also: Dein Code berührt die Bemaßung überhaupt nicht, es wird nur eine Systemvaraible gändert. Selbst wenn die Bemaßung keinen Bemstil hat, läuft das so in R14 nicht mehr - das wäre in R12 noch gegangen, wenn ich mich recht erinnere.

Dumm ist nur, dass ich hier auch nur im Gedächtnis wühlen und raten kann, habe derzeit kein R14 mehr (ach ja, muss bei dir wohl ein 14.01 sein, sonst wäre doch kein VBA drin, oder?). Kann nur hoffen, dass mein Beitrag dich jetzt mal wirklich weiter bringt - bisher war das ja eher eine Anti-Hilfe;-)

Gruß, Axel Strube-Zettler

------------------
(defun - Lisp over night - AutoLisp-Programmierung für AutoCad - Da weiß man, wann man's hat
Meine AutoLisp-Seiten Mein Angriff auf dein Zwerchfell Mein Lexikon der Fotografie Mein gereimtes Gesülze

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

---

Ich kanns nur in Lisp, das hier sollte wohl auch mit AutoCAD 14 laufen da ich vollständige auf VisalLisp Funktionen verzichtet habe.
Dafür ist es auch etwas länger geworden und nicht so elegant wie der Code von CADmium.

Code:

---

; Hauptprogrammm
; Beispielprogramm zum Einsatz der Bemaßungsüberschreibungen
; die in EEDs gespeichert sind.
(DEFUN C:BEMU ( / ss cnt)
  (PROMPT "\nÜbersteuerung von Bemaßungsvariablen hier DIMDEC = 3")
  (PROMPT "\nBemaßungen wählen:")
  (SETQ ss (SSGET (LIST (CONS 0 "DIMENSION"))))
  (IF ss
    (PROGN
      (SETQ cnt (SSLENGTH ss))
      (PROMPT (STRCAT "\nBearbeite " (ITOA cnt) " Bemaßungsobjekte"))
      (WHILE (>= (SETQ cnt (1- cnt)) 0)
        (BEMUEBERSCHREIBUNG (SSNAME ss cnt)  271 1070 3) ; 271 ist der Code von DIMDEC
      )
    )
  )
  (PRIN1)
)
; Unterprogramm
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(DEFUN Bemueberschreibung  (elname BemVarCode WertCode Wert
    / eliste XDaten NeueXDaten
    nurnochfertigwerden elementaendern dstyle)
  (SETQ eliste (ENTGET elname (LIST "ACAD"))
Xdaten (CADR (ASSOC -3 eliste))
  )
  (IF (NOT XDaten) ; Überhaupt keine Stilüberschreibungen vorhanden
    (PROGN
      (PRINT (SETQ NeueXDaten
    (LIST "ACAD"
  (CONS 1000 "DSTYLE")
  (CONS 1002 "{")
  (CONS 1070 BemVarCode)
  (CONS WertCode Wert)
  (CONS 1002 "}")
    )
      )
      )
      (SETQ eliste (APPEND eliste (LIST (LIST -3 NeueXDaten))))
    )
    (PROGN
      (FOREACH element XDaten
(COND
  (nurnochfertigwerden)
  (elementaendern
  (SETQ element     (CONS WertCode Wert)
elementaendern     NIL
nurnochfertigwerden 'T
  )
  )
  ((EQUAL element '(1000 . "DSTYLE")); Bemaßungsstilüberschreibungen gefunden
  (SETQ dstyle 'T)
  )
  ((AND dstyle (EQUAL element '(1002 . "}")))
  ; Ende der Bemaßungsstilüberschreibungen gefunden und noch nicht "nurnochfertigwerden" gesetzt
  (SETQ NeueXDaten (CONS (CONS WertCode Wert) (CONS (CONS 1070 BemVarCode) NeueXDaten))
nurnochfertigwerden  'T
dstyle NIL
  )
  )
  ((AND dstyle (= (CDR element) BemVarCode)) ; nachfolgende Bemaßungsstilüberschreibung ändern
  (SETQ elementaendern 'T)
  )
) ;ende COND
(SETQ NeueXdaten (CONS element NeueXdaten))
      )
      (SETQ eliste (SUBST (CONS -3 (LIST (REVERSE NeueXDaten)))
  (ASSOC -3 eliste)
  eliste
          )
      )
    )
  )
  (ENTMOD eliste)
)

---

Mit freundlichem Gruß

Udo Hübner

------------------
Nichts ist so einfach, dass man's nicht falsch machen könnte.

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

---

Nach längerer Überlegungspause bin ich auf die Lösung gekommen und wenn ich die hier gleich bekannt gebe, hauen sich bestimmt manche Leute, die sich mit diesem Thema beschäftigt haben, an die Stirn:
Das Geheimnis heißt: XData     

Hier mal der Code, der das alles hinbekommt:

Sub BemFarbÄndern()
    Dim DimObj As AcadDimRotated, ReturnCode As Variant
    Dim XData As Variant, XType As Variant, Index As Integer
    Dim SsetDim As AcadSelectionSet
    Dim groupValue(0) As Integer, dataValue(0) As Variant
    Dim groupCode As Variant, dataCode As Variant
   
    'Definiert Auswahlsatz mit Filter nur für Dimensionen
    Set SsetDim = ThisDrawing.SelectionSets.Add("DimSSET")
    groupValue(0) = 0: dataValue(0) = "DIMENSION"
    groupCode = groupValue: dataCode = dataValue
    SsetDim.SelectOnScreen groupCode, dataCode
   
    For Each DimObj In SsetDim
        ReturnCode = BemDataValue(DimObj) 'Funktion gibt Xdaten zurück
        XData = ReturnCode(1)
        Index = PosInField(XData, "147") + 1
        XData(Index) = 100 'Wert für Textabstand von der Maßlinie
        Index = PosInField(XData, "178") + 1
        XData(Index) = 252 'Wert für Farbe des Textes
        Index = PosInField(XData, "177") + 1
        XData(Index) = 11 'Wert für Farbe der Maßlinie
        Index = PosInField(XData, "176") + 1
        XData(Index) = 252 'Wert für Farbe der Hilfslinie
       
        BemDataValue DimObj, ReturnCode(0), XData 'Funktion gibt geänderte Xdaten-Satz zurück an das Objekt
    Next DimObj
    SsetDim.Clear
    Set SsetDim = Nothing
End Sub

Function BemDataValue(BemObj As AcadDimRotated, Optional XType As Variant, Optional XData As Variant) As Variant
    Dim ReturnWert(1) As Variant
    If IsMissing(XType) Then
        BemObj.GetXData "", XType, XData
        ReturnWert(0) = XType
        ReturnWert(1) = XData
        BemDataValue = ReturnWert
    Else
        BemObj.SetXData XType, XData
        BemObj.Update
        BemDataValue = True
    End If
End Function

Function PosInField(Feld As Variant, SucheNach As Variant) As Integer
    Dim Zähler As Integer, MomPos As Variant
    If SucheNach <> "" Then
        For Each MomPos In Feld
          If StrComp(MomPos, SucheNach, vbTextCompare) = 0 Then Exit For
          Zähler = Zähler + 1
        Next
        If Zähler <= UBound(Feld) Then
          PosInField = Zähler
        Else
          PosInField = -1
        End If
    Else
        PosInField = -1
    End If
End Function

Danke nochmal an alle, die versucht haben mir zu helfen!

**** Ein frohes neues Jahr ****

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