---

Hi,

ich denke gerade darüber nach, ob es geht, eine Maßzahl zu unterstreichen, wenn der Wert ungleich "<>" ist. Geht so etwas und ist ein Reaktor der gegebene Weg ?
Hat sich von Euch (REAKTOR- & LISP-FREAKS :-)) so etwas gebastelt ? Wie sieht so etwas aus ?

Grüße

CAD-Tötti

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

---

Zwar kein Reactor aber VBA macht da auch glücklich.
Kannst die Eigenschaften des Maßtextes entsprechend deinen Vorstellungen (Unterstreichung, Style, etc) anpassen. Im Source wird nur die Farbe auf Blau geändert bzw auf die "DimClrt" zurückgesezt.

Option Explicit
Sub ad_VerifyDims()
  Dim adDimension As AcadDimension
  Dim adSS As AcadSelectionSet
  Dim fType(0 To 1) As Integer, fData(0 To 1)
  Dim adOverRideCount As Integer
  adOverRideCount = 0
  Set adSS = ThisDrawing.SelectionSets.Add("adSS")
  If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS")
  adSS.Clear
  fType(0) = 0: fData(0) = "DIMENSION"
  fType(1) = 100: fData(1) = "*"
  adSS.Select acSelectionSetAll, , , fType, fData
  For Each adDimension In adSS
    If adDimension.TextOverride <> "" Then
      adDimension.TextColor = acBlue
      adOverRideCount = adOverRideCount + 1
    End If
  Next adDimension
  ThisDrawing.Application.Update
Select Case adOverRideCount
Case 0
MsgBox "Keine überschriebene Bemassung gefunden.", vbOKOnly, ThisDrawing.FullName
Case 1
MsgBox adOverRideCount & " überschriebene Bemassung gefunden, die Maßzahl wurde auf Blau gesetz !", vbCritical, ThisDrawing.FullName
Case Is > 1
MsgBox adOverRideCount & " überschriebene Bemassungen gefunden, die Maßzahl wurde auf Blau gesetz !", vbCritical, ThisDrawing.FullName
  End Select
  adSS.Delete
End Sub
Sub ad_VerifyDimsResetColor()
  Dim adDimension As AcadDimension
  Dim adSS As AcadSelectionSet
  Dim fType(0 To 1) As Integer, fData(0 To 1)
  Dim adOverRideCount As Integer
  Set adSS = ThisDrawing.SelectionSets.Add("adSS")
  If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS")
  adSS.Clear
  fType(0) = 0: fData(0) = "DIMENSION": fType(1) = 100: fData(1) = "*"
  adSS.Select acSelectionSetAll, , , fType, fData
  For Each adDimension In adSS
    If adDimension.TextColor = acBlue Then
      adDimension.TextColor = ThisDrawing.GetVariable("DimClrT")
    End If
  Next adDimension
  ThisDrawing.Application.Update
  adSS.Delete
End Sub

------------------
(entmake (entget (entlast)))

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

---

Irgendwie gibt es eine Fehlermeldung wenn ich die (.lsp oder .dvb ???) Datei mit appload laden möchte. Ich kenne mich leider nicht aus mit VBA unter ACAD. Wie macht man das ?

Zu der Funktion:
merkt die Funktion von alleine, wenn der Maßtext zumindest aus einem Teil nicht aus "<>" besteht oder muß ich da noch irgendwas machen ?

Grüße

CAD-Tötti

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

---

ad_VerifyDims.zip

Zitat:

---

Original erstellt von CAD-Tötti:
Irgendwie gibt es eine Fehlermeldung wenn ich die (.lsp oder .dvb ???) Datei mit appload laden möchte. Ich kenne mich leider nicht aus mit VBA unter ACAD. Wie macht man das ?

---

Alt+F11, Neues Modul, den Code einfügen, ein Projektname festlegen, Speichern, dann über Autocad | Extra | Makros | Laden | ...
in der mnu...
ID_Check_Bems  [_Button("blabla", "bmp1.bmp", bmp2bmp")]^C^C -vbarun ThisDrawing.MakroName

Zitat:

---

Zu der Funktion:
merkt die Funktion von alleine, wenn der Maßtext zumindest aus einem Teil nicht aus "<>" besteht oder muß ich da noch irgendwas machen ?

---

    If adDimension.TextOverride <> "" Then
      adDimension.TextColor = acBlue
      adOverRideCount = adOverRideCount + 1
    End If

sollte eigentlich schon 

------------------
(entmake (entget (entlast)))

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

---

*heul*

eigentlich wär mir ein Reaktor lieber :-)

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