Help with dimension lisp

[Guest]

Hi , I am using this code for dimension open/close polylines. Sometimes I have to dimension multiple close polylines like the attach file, and for the same side of the polygon have duplicate dimensions (one for each polygon). I need help to update the code

 

a) Select multiple polylines (not one every time)

b) Don't have duplicate dimensions

 

;qq.lsp  
;               
;******************************************************
(Defun C:qq (/ txtstl txtsze stryn prfx sufx svr scl ht pt pti ptx pty
                  old oldpl nodpl ptyp pllst i n prin meta distmeta ptdist
                  angprin angmeta angtxt ptp alfa nlin xlin ylin dlin flg 
                  xreg yreg na xa ya)
;*************drawing set-up***************************
;
  (command "undo" "m")
  (setvar "unitmode" 0)
  (setvar "aunits" 2)
  (setvar "angbase" (/ pi 2))
  (setvar "angdir" 1)
  (setvar "auprec" 4)
  (setvar "lunits" 2)
  (setvar "luprec" 3)
  (setvar "dimzin" 0)
(setq svr(getvar "osmode"))
(setq txtstl(getvar "textstyle"))
(setq txtsze(getvar "textsize"))
(setvar "cmdecho" 0)
(setq flg 1)
(setvar "cmdecho" 0)
(command "layer" "m" "diast" "")
(setq scl(/ (getreal  "\n select scale  (100,200,500,etc) : ") 100))
(setq ht(* 0.175 scl))

:********BOUNDARY LINE**********
(setvar "osmode" 0)
(setq old(entsel "\n select lwpolyline: "))
(setq oldpl(entget(car old)))
(setq nodpl(cdr(assoc 90 oldpl)))
(setq ptyp (cdr(assoc 70 oldpl)))
(command "area" "e" old)
(setq pllst '())
(setq i 0)
(setq n 0)
(while (car(nth i oldpl))
       (if (= (car(nth i oldpl)) 10) 
              (progn
                    (setq pllst (append pllst (list (cdr(nth i oldpl)))))
                    (setq n(+ 1 n))
              );endprogn
       );endif
        (setq i (+ i 1))
);endwhile
(if (= ptyp 1)
  (progn
        (setq pllst (append pllst (list(nth 0 pllst))))
        (setq pllst (cdr pllst))
  );endprogn     
);endif
; (main)
;close defun
;(defun main()
;*******CIRCLES ON LANDMARKS***********
(command "style" "diast" "wgsimpl.shx" "" "" "" "" "")
(setq alfa 193)
(command "circle" pt (/ ht 5))
(command "copy" pt "" "m" pt)
(foreach n pllst (command n))
(command "")
(command "erase" pt "")
(setq i 0 prin 0 meta 0)
(while (car(nth i pllst))
 (setq prin (- i 1))
 (setq meta (+ i 1))
   (if (= i 0)
              (setq prin (- n 1))
   )
   (if (= i (- n 1))
              (setq meta 0)
   )
 (setq angprin (angle (nth i pllst) (nth prin pllst)))
 (setq angmeta (angle (nth i pllst) (nth meta pllst)))
 (setq distmeta (distance (nth i pllst) (nth meta pllst)))
 
;**************DISTANCES BETWEEN LANDMARKS********************** 
 (setq ptdist (polar 
                    (polar (nth i pllst) angmeta (/ distmeta 2)) 
                    (+ angmeta (* (/ pi 2) flg)) (* 0.25 ht)))
 (setq angtxt(- 500 (/ (* 400 angmeta) (* 2 pi)))) 
 (if (> angtxt 400)
             (setq angtxt (- angtxt 400))
 )
 (if (> angtxt 200)
       (progn
             (setq ptdist (polar 
                                (polar (nth i pllst) angmeta (/ distmeta 2)) 
                                (+ angmeta (* (/ pi 2) flg)) (* 1.25 ht)))
             (setq angtxt (- angtxt 200))
       );endprogn
 )
 (command "text" "j" "c" 
                        ptdist ht 
                        angtxt
                        (rtos distmeta 2 2)
 )
   (setq i (+ i 1))
);endwhile
(if (= ptyp 0)
              (command "erase" "l" "")
)


;**********
; (initget "Yes No")
; (setq stryn(getkword "\nSatisfied? (Yes or No) :")) 
; (if (= stryn "Yes")
;     (ok)
; );end if
; (if (= stryn "No")
;     (progn
;           (command "undo" "b")
;           (command "undo" "m")
;           (setq flg(* -1 flg))
;           (main)
;     )
; );end if
; (ok)
;close defun
;(defun ok ()
;*********END*********************************** 
(setvar "osmode" svr)
(setvar "cmdecho" 1)
(setvar "textstyle" txtstl)
(setvar "textsize"  txtsze)
(princ)
);close defun

 

Thanks

Drawing1.dwg

[Guest]

Any options? It can be done?

 

Thanks

[mhupp]

Modified this. You will have to add in your scale and angles variables

 

 

 

 

 

AD-Automatic Dimension Autocad.LSP

Edited January 12, 2023 by mhupp

[Guest]

Hi mhupp. It gives me this error.

 

Command: (LOAD "E:/Downloads/AD-Automatic Dimension Autocad.LSP") C:AD
Command: ad
ADError: no function definition: GETDICTVAR

 

I see in the link that use dimensions. I use it for topographic drawings. In topographic drawings, use only text for dimensions. Is it possible to work for text ?

 

Thanks

[mhupp]

updated file again.

 

5 hours ago, prodromosm said:

In topographic drawings, use only text for dimensions. Is it possible to work for text ?

 

That's what I updated. but your using gradians for angle and can't figure that out so text looks like this.

 

Edited January 12, 2023 by mhupp

[Guest]

Hi mhupp. I add some changes to the code. I try to change the units to degrees in the beginning and to grads at the end, but I still have problem with the angle of the text. I and text style  , create it, but the text goes to STANDARD !!!

 

;AutoDimension polylines
; - draw dimension(s) from vertex to vertex for selected polylines
; - add arc length for arc segments.
; Stefan M. 10.11.2015 - for KimProjects.com

(defun C:AD ( / *error* a acdoc b c d dim e fd ht i o p1 p2 p3 pc pm rad sd space ss u opt isLine)

;units to degrees
   (mapcar 'setvar (list 'aunits 'auprec 'angdir 'angbase 'lunits 'luprec 'insunits 'lightingunits) (list 0 4 0 0 2 3 6 2))
;------------Dont delete it, i use it for the text height, I deactivate it for the moment ----------------
;   (setq scl (getvar "useri1"))
;   (setq ht(* 0.00175 scl))
;---------------------------------------------------------------------------------------------------------------------
   (command "-style" "diast" "wgsimpl.shx" "0" "1" "0" "N" "N" "N")
   (command "_layer" "_m" "DIM-TEXT" "_c" "93" "" "_lw" "0.30" "" "")
  (setq acDoc (vla-get-activedocument (vlax-get-acad-object))
        space (vlax-get acDoc (if (= (getvar 'cvport) 1) 'paperspase 'modelspace))
        dim (getvar 'dimstyle)
        ht  (* 1.0 (getvar 'dimtxt) (if (= 0 (getvar 'dimanno)) (getvar 'dimscale) (/ 1.0 (getvar 'cannoscalevalue))))
        )
  (vla-startundomark acDoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nADError: " msg))
      )
    (vla-endundomark acdoc)
    (princ)
    )
  
  (setq opt (mapcar
              '(lambda (a b)
                 (cond
                   ((getdictvar "AD_otions" a))
                   ((setdictvar "AD_otions" a b))
                   )
                 )
              '("Linear" "Arc")
              '("b0" "c0")
              )
        )
  
 ; (initget "Options")
 ; (if
 ;   (eq (getkword "\nPress enter to continue or [Options]: ") "Options")
 ;   (setq opt (AD_options opt))
 ;   )
  
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i)))
            o (vlax-ename->vla-object e)
            a (vlax-curve-getstartparam e)
            c (vlax-curve-getendparam   e)
            b nil
            isLine (wcmatch (vla-get-Objectname o) "AcDbLine,AcDbArc")
            )
      (while (<= (setq b (if isLine (if b (1+ b) c) (1+ a))) c)
        (setq p1 (vlax-curve-getpointatparam e a)
              p2 (vlax-curve-getpointatparam e b)
              u  (angle p1 p2)
              pm (vlax-curve-getpointatparam e (/ (+ a b) 2.0))
              sd (vlax-curve-getsecondderiv  e (/ (+ a b) 2.0))
              rad (distance '(0 0 0) sd)
              d  (cond (isLine) ((not (minusp (vla-getbulge o a)))))
              pc (mapcar (if d '+ '-) pm sd)
              p3 (if
                   (or (equal rad 0.0 1e-8) (eq (cadr opt) "c2"))
                   (if
                     (eq (car opt) "b0")
                     (polar pm (+ (atan (/ (sin u) (cos u))) (/ pi 2.0)) ht)
                     (polar pm (- (atan (/ (sin u) (cos u))) (/ pi 2.0)) (* 1.75 ht))
                     )
                   (if
                     (eq (cadr opt) "c0")
                     (polar pm (angle pm pc) (if (<= 1e-4 (angle pc pm) pi) (* 1.75 ht) ht))
                     (polar pm (angle pc pm) (if (<= 1e-4 (angle pc pm) pi) ht (* 1.75 ht)))
                   )
                 )
               )
        (entmake (list (cons 0 "TEXT") (cons 10 p3) (cons 11 p3) (cons 40 ht) (cons 1 (rtos (distance p1 p2) 2 2)) '(8 . "DIM-TEXT") '(73 . 2) '(72 . 1)))
        (setq a (1+ a))
        )
      )
    )
  (vla-endundomark acdoc)
  (princ)

;Units to grads
(mapcar 'setvar (list 'aunits 'auprec 'angdir 'angbase 'lunits 'luprec 'insunits 'lightingunits) (list 2 4 1 (/ pi 2) 2 3 6 2))

;layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
 (princ)
);close defun


(defun AD_options (old / a1 a2 b1 b2 dcl dcl_id file r)
  (setq
    a1 (car old)
    a2 (cadr old)
    dcl (open (setq file (vl-filename-mktemp "AD" (getvar 'dwgprefix) ".dcl")) "w")
  )
  (write-line
    "AD: dialog { label = \"Dimension Polyline Options\" ;
    : boxed_radio_column { label = \"Linear dimension position\" ; key = \"a1\";
    : radio_button { label = \"Above line\" ; key = \"b0\";}
    : radio_button { label = \"Below line\" ; key = \"b1\";}}
    : boxed_radio_column { label = \"Arc dimension position\" ; key = \"a2\";
    : radio_button { label = \"Inside arc\" ; key = \"c0\";}
    : radio_button { label = \"Outside arc\" ; key = \"c1\";}
    : radio_button { label = \"As for lines\" ; key = \"c2\";}}
    ok_cancel ;}"
    dcl)
  (close dcl)
  (if
    (< 0 (setq dcl_id (load_dialog file)))
    (if
      (new_dialog "AD" dcl_id)
      (progn
        (action_tile "a1" "(setq b1 $value)")
        (action_tile "a2" "(setq b2 $value)")
        (set_tile "a1" (setq b1 a1))
        (set_tile "a2" (setq b2 a2))
        (setq r (start_dialog))
        (unload_dialog dcl_id)
        )
      )
    )
  (if (findfile file) (vl-file-delete file))
  (if
    (= r 1)
    (mapcar 'setdictvar 
      '("AD_otions" "AD_otions")
      '("Linear" "Arc")
      (list b1 b2)
    )
    (list a1 a2)
  )
)
    
(defun getdictvar (dict var / dict_ename)
  (if
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (cdr (assoc 1 (dictsearch dict_ename var)))
  )
)

(defun setdictvar (dict var val / dict_name record)
  (or
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (setq dict_ename (dictadd (namedobjdict) dict (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))))
    )
  (if
    (setq record (dictsearch dict_ename var))
    (entmod (subst (cons 1 val) (assoc 1 record) record))
    (dictadd
      dict_ename
      var
      (entmakex
        (list
          '(0 . "DICTIONARYVAR")
          '(100 . "DictionaryVariables")
          '(280 . 0)
          (cons 1 val)
        )
      )
    )
  )
  val
)
  

 

[mhupp]

7 minutes ago, prodromosm said:

Hi mhupp. I add some changes to the code. I try to change the units to degrees in the beginning and to grads at the end, but I still have problem with the angle of the text. I and text style  , create it, but the text goes to STANDARD !!!

 

Update the entmake to include the style name '(7 . "style name") and (cons 51 anglevariable)

(entmake (list (cons 0 "TEXT") (cons 10 p3) (cons 11 p3) (cons 40 ht) (cons 1 (rtos (distance p1 p2) 2 2)) '(7 . "diast") '(8 . "DIM-TEXT") '(73 . 2) '(72 . 1)))

 

 

[Guest]

Hi, I clean up the code. I don't know if I left something unnecessary. I still have a problem with the angle of the text. Furthermore, I attach a *dwg  file will an example how the correct angle must be at the end. Can any one help

 

 

(defun c:foo( / *error* a acdoc b c d dim e fd ht i o p1 p2 p3 pc pm rad sd space ss u opt isLine)

;------------Dont delete it, i use it for the text height, I deactivate it for the moment ----------------
;   (setq scl (getvar "useri1"))
;   (setq ht(* 0.00175 scl))
;---------------------------------------------------------------------------------------------------------------------
   (command "-style" "diast" "wgsimpl.shx" "0" "1" "0" "N" "N" "N")
   (command "_layer" "_m" "DIM-TEXT" "_c" "93" "" "_lw" "0.30" "" "")
  (setq acDoc (vla-get-activedocument (vlax-get-acad-object))
        space (vlax-get acDoc (if (= (getvar 'cvport) 1) 'paperspase 'modelspace))
        dim (getvar 'dimstyle)
        ht  (* 1.0 (getvar 'dimtxt) (if (= 0 (getvar 'dimanno)) (getvar 'dimscale) (/ 1.0 (getvar 'cannoscalevalue))))
        )
  (vla-startundomark acDoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nADError: " msg))
      )
    (vla-endundomark acdoc)
    (princ)
    )
  
  (setq opt (mapcar
              '(lambda (a b)
                 (cond
                   ((getdictvar "AD_otions" a))
                   ((setdictvar "AD_otions" a b))
                   )
                 )
              '("Linear" "Arc")
              '("b0" "c0")
              )
        )
  
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i)))
            o (vlax-ename->vla-object e)
            a (vlax-curve-getstartparam e)
            c (vlax-curve-getendparam   e)
            b nil
            isLine (wcmatch (vla-get-Objectname o) "AcDbLine,AcDbArc")
            )
      (while (<= (setq b (if isLine (if b (1+ b) c) (1+ a))) c)
        (setq p1 (vlax-curve-getpointatparam e a)
              p2 (vlax-curve-getpointatparam e b)
              u  (angle p1 p2)
              pm (vlax-curve-getpointatparam e (/ (+ a b) 2.0))
              sd (vlax-curve-getsecondderiv  e (/ (+ a b) 2.0))
              rad (distance '(0 0 0) sd)
              d  (cond (isLine) ((not (minusp (vla-getbulge o a)))))
              pc (mapcar (if d '+ '-) pm sd)
              p3 (if
                   (or (equal rad 0.0 1e-8) (eq (cadr opt) "c2"))
                   (if
                     (eq (car opt) "b0")
                     (polar pm (+ (atan (/ (sin u) (cos u))) (/ pi 2.0)) ht)
                     (polar pm (- (atan (/ (sin u) (cos u))) (/ pi 2.0)) (* 1.75 ht))
                     )
                   (if
                     (eq (cadr opt) "c0")
                     (polar pm (angle pm pc) (if (<= 1e-4 (angle pc pm) pi) (* 1.75 ht) ht))
                     (polar pm (angle pc pm) (if (<= 1e-4 (angle pc pm) pi) ht (* 1.75 ht)))
                   )
                 )
               )
        (entmake (list (cons 0 "TEXT") (cons 10 p3) (cons 11 p3) (cons 40 ht) (cons 1 (rtos (distance p1 p2) 2 2)) '(7 . "diast") '(8 . "DIM-TEXT") '(73 . 2) '(72 . 1)))
        (setq a (1+ a))
        )
      )
    )
  (vla-endundomark acdoc)
  (princ)


;layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
 (princ)
);close defun



    
(defun getdictvar (dict var / dict_ename)
  (if
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (cdr (assoc 1 (dictsearch dict_ename var)))
  )
)

(defun setdictvar (dict var val / dict_name record)
  (or
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (setq dict_ename (dictadd (namedobjdict) dict (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))))
    )
  (if
    (setq record (dictsearch dict_ename var))
    (entmod (subst (cons 1 val) (assoc 1 record) record))
    (dictadd
      dict_ename
      var
      (entmakex
        (list
          '(0 . "DICTIONARYVAR")
          '(100 . "DictionaryVariables")
          '(280 . 0)
          (cons 1 val)
        )
      )
    )
  )
  val
)
  

 

 

Thanks

test.dwg

[Guest]

I clean a little more the code. Any ideas how to  fix the text angle?

 

(defun c:foo( / *error* a acdoc b c d scl e fd ht i o p1 p2 p3 pc pm rad sd space ss u opt isLine)

;------------Dont delete it, i use it for the text height, I deactivate it for the moment ----------------
;   (setq scl (getvar "useri1"))
;   (setq ht (* 0.00175 scl))
;---------------------------------------------------------------------------------------------------------------------
   (command "-style" "diast" "wgsimpl.shx" "0" "1" "0" "N" "N" "N")
   (command "_layer" "_m" "DIM-TEXT" "_c" "93" "" "_lw" "0.30" "" "")
  (setq acDoc (vla-get-activedocument (vlax-get-acad-object))
        space (vlax-get acDoc (if (= (getvar 'cvport) 1) 'paperspase 'modelspace))
        ht  (* 1.0 (getvar 'dimtxt) (if (= 0 (getvar 'dimanno)) (getvar 'dimscale) (/ 1.0 (getvar 'cannoscalevalue))))
        )
  (vla-startundomark acDoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nADError: " msg))
      )
    (vla-endundomark acdoc)
    (princ)
    )
     
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i)))
            o (vlax-ename->vla-object e)
            a (vlax-curve-getstartparam e)
            c (vlax-curve-getendparam   e)
            b nil
            isLine (wcmatch (vla-get-Objectname o) "AcDbLine,AcDbArc")
            )
      (while (<= (setq b (if isLine (if b (1+ b) c) (1+ a))) c)
        (setq p1 (vlax-curve-getpointatparam e a)
              p2 (vlax-curve-getpointatparam e b)
              u  (angle p1 p2)
              pm (vlax-curve-getpointatparam e (/ (+ a b) 2.0))
              sd (vlax-curve-getsecondderiv  e (/ (+ a b) 2.0))
              rad (distance '(0 0 0) sd)
              d  (cond (isLine) ((not (minusp (vla-getbulge o a)))))
              pc (mapcar (if d '+ '-) pm sd)
              p3 (if
                   (or (equal rad 0.0 1e-8) (eq (cadr opt) "c2"))
                   (if
                     (eq (car opt) "b0")
                     (polar pm (+ (atan (/ (sin u) (cos u))) (/ pi 2.0)) ht)
                     (polar pm (- (atan (/ (sin u) (cos u))) (/ pi 2.0)) (* 1.75 ht))
                     )
                   (if
                     (eq (cadr opt) "c0")
                     (polar pm (angle pm pc) (if (<= 1e-4 (angle pc pm) pi) (* 1.75 ht) ht))
                     (polar pm (angle pc pm) (if (<= 1e-4 (angle pc pm) pi) ht (* 1.75 ht)))
                   )
                 )
               )
        (entmake (list (cons 0 "TEXT") (cons 10 p3) (cons 11 p3) (cons 40 ht) (cons 1 (rtos (distance p1 p2) 2 2)) '(7 . "diast") '(8 . "DIM-TEXT") '(73 . 2) '(72 . 1)))
        (setq a (1+ a))
        )
      )
    )
  (vla-endundomark acdoc)
  (princ)


;layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
 (princ)
);close defun



    
(defun getdictvar (dict var / dict_ename)
  (if
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (cdr (assoc 1 (dictsearch dict_ename var)))
  )
)

(defun setdictvar (dict var val / dict_name record)
  (or
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (setq dict_ename (dictadd (namedobjdict) dict (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))))
    )
  (if
    (setq record (dictsearch dict_ename var))
    (entmod (subst (cons 1 val) (assoc 1 record) record))
    (dictadd
      dict_ename
      var
      (entmakex
        (list
          '(0 . "DICTIONARYVAR")
          '(100 . "DictionaryVariables")
          '(280 . 0)
          (cons 1 val)
        )
      )
    )
  )
  val
)
  

 

Thanks

test(1).dwg

[Guest]

Can anyone fix the angle rotation like test(1).dwg ?

 

Thanks

[1958]

 

1 hour ago, prodromosm said:

Can anyone fix the angle rotation like test(1).dwg ?

 

Thanks

For individual polylines

 

 

 

727.LSP

Edited January 14, 2023 by 1958

[1958]

With checking for polyline closure

737.LSP

[Guest]

Hi 1958.

1) Is any way all parametric dimension be inside the polygon and only in the sides, will be in touch, have one dimension

2) If it is possible to select window more than one polyline.

3) In topographic drawings, all text for dimensions are inside the polygons.

 

Thanks

 

test.dwg

Edited January 14, 2023 by prodromosm

[1958]

Do a check for duplicate texts and delete duplicates. You can write a simple procedure. Sorry for my english, I use translate.google.com

[Guest]

Hi, I update the code and correct the angle problem for the text. Work for multiple polylines.

 

I have these problems :

 

1) I don't know haw to delete duplicate text

2) The dimension are not all inside the polygon

 

(defun c:foo( / *error* a acdoc b c d scl e fd ht i o p1 p2 p3 pc pm rad sd space ss u opt isLine)

;------------Dont delete it, i use it for the text height, I deactivate it for the moment ----------------
;   (setq scl (getvar "useri1"))
;   (setq ht (* 0.00175 scl))
;---------------------------------------------------------------------------------------------------------------------
   (command "-style" "diast" "wgsimpl.shx" "0" "1" "0" "N" "N" "N")
   (command "_layer" "_m" "DIM-TEXT" "_c" "93" "" "_lw" "0.30" "" "")
  (setq acDoc (vla-get-activedocument (vlax-get-acad-object))
        space (vlax-get acDoc (if (= (getvar 'cvport) 1) 'paperspase 'modelspace))
        ht  (* 1.0 (getvar 'dimtxt) (if (= 0 (getvar 'dimanno)) (getvar 'dimscale) (/ 1.0 (getvar 'cannoscalevalue))))
        )
  (vla-startundomark acDoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nADError: " msg))
      )
    (vla-endundomark acdoc)
    (princ)
    )
  
  (setq opt (mapcar
              '(lambda (a b)
                 (cond
                   ((getdictvar "AD_otions" a))
                   ((setdictvar "AD_otions" a b))
                   )
                 )
              '("Linear" "Arc")
              '("b0" "c0")
              )
        )
  
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i)))
            o (vlax-ename->vla-object e)
            a (vlax-curve-getstartparam e)
            c (vlax-curve-getendparam   e)
            b nil
            isLine (wcmatch (vla-get-Objectname o) "AcDbLine,AcDbArc")
            )
      (while (<= (setq b (if isLine (if b (1+ b) c) (1+ a))) c)
        (setq p1 (vlax-curve-getpointatparam e a)
              p2 (vlax-curve-getpointatparam e b)
              u  (angle p1 p2)
              pm (vlax-curve-getpointatparam e (/ (+ a b) 2.0))
              sd (vlax-curve-getsecondderiv  e (/ (+ a b) 2.0))
              rad (distance '(0 0 0) sd)
              d  (cond (isLine) ((not (minusp (vla-getbulge o a)))))
              pc (mapcar (if d '+ '-) pm sd)
              p3 (if
                   (or (equal rad 0.0 1e-8) (eq (cadr opt) "c2"))
                   (if
                     (eq (car opt) "b0")
                     (polar pm (+ (atan (/ (sin u) (cos u))) (/ pi 2.0)) ht)
                     (polar pm (- (atan (/ (sin u) (cos u))) (/ pi 2.0)) (* 1.75 ht))
                     )
                   (if
                     (eq (cadr opt) "c0")
                     (polar pm (angle pm pc) (if (<= 1e-4 (angle pc pm) pi) (* 1.75 ht) ht))
                     (polar pm (angle pc pm) (if (<= 1e-4 (angle pc pm) pi) ht (* 1.75 ht)))
                   )
                 )
               )
        (entmake (list (cons 0 "TEXT") (cons 10 p3) (cons 11 p3) (cons 40 ht) (cons 50 u) (cons 1 (rtos (distance p1 p2) 2 2)) '(7 . "diast") '(8 . "DIM-TEXT") '(73 . 2) '(72 . 1)))
        (setq a (1+ a))
        )
      )
    )
  (vla-endundomark acdoc)
  (princ)


;layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
 (princ)
 (princ)
);close defun



    
(defun getdictvar (dict var / dict_ename)
  (if
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (cdr (assoc 1 (dictsearch dict_ename var)))
  )
)

(defun setdictvar (dict var val / dict_name record)
  (or
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (setq dict_ename (dictadd (namedobjdict) dict (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))))
    )
  (if
    (setq record (dictsearch dict_ename var))
    (entmod (subst (cons 1 val) (assoc 1 record) record))
    (dictadd
      dict_ename
      var
      (entmakex
        (list
          '(0 . "DICTIONARYVAR")
          '(100 . "DictionaryVariables")
          '(280 . 0)
          (cons 1 val)
        )
      )
    )
  )
  val
)

 

 

Can any one help ?

 

Thanks

Edited January 14, 2023 by prodromosm

[Guest]

Hi, I update the code to delete the duplicate dimension.

Can anyone help me to fix dimensions to be all inside the polygon? Like the example?

 

(defun c:foo3 ( / *error* a acdoc b c d scl e fd ht i o p1 p2 p3 pc pm rad sd space ss u opt isLine)

;------------Dont delete it, i use it for the text height, I deactivate it for the moment ----------------
;   (setq scl (getvar "useri1"))
;   (setq ht (* 0.00175 scl))
;---------------------------------------------------------------------------------------------------------------------
   (command "-style" "diast" "wgsimpl.shx" "0" "1" "0" "N" "N" "N")
   (command "_layer" "_m" "DIM-TEXT" "_c" "93" "" "_lw" "0.30" "" "")
  (setq acDoc (vla-get-activedocument (vlax-get-acad-object))
        space (vlax-get acDoc (if (= (getvar 'cvport) 1) 'paperspase 'modelspace))
        ht  (* 1.0 (getvar 'dimtxt) (if (= 0 (getvar 'dimanno)) (getvar 'dimscale) (/ 1.0 (getvar 'cannoscalevalue))))
        )
  (vla-startundomark acDoc)

  (defun *error* (msg)
    (and
      msg
      (not (wcmatch (strcase msg) "*CANCEL*,*QUIT*,*BREAK*"))
      (princ (strcat "\nADError: " msg))
      )
    (vla-endundomark acdoc)
    (princ)
    )
  
    
  (if
    (setq ss (ssget '((0 . "LWPOLYLINE,LINE,ARC"))))
    (repeat (setq i (sslength ss))
      (setq e (ssname ss (setq i (1- i)))
            o (vlax-ename->vla-object e)
            a (vlax-curve-getstartparam e)
            c (vlax-curve-getendparam   e)
            b nil
            isLine (wcmatch (vla-get-Objectname o) "AcDbLine,AcDbArc")
            )
      (while (<= (setq b (if isLine (if b (1+ b) c) (1+ a))) c)
        (setq p1 (vlax-curve-getpointatparam e a)
              p2 (vlax-curve-getpointatparam e b)
              u  (angle p1 p2)
              pm (vlax-curve-getpointatparam e (/ (+ a b) 2.0))
              sd (vlax-curve-getsecondderiv  e (/ (+ a b) 2.0))
              rad (distance '(0 0 0) sd)
              d  (cond (isLine) ((not (minusp (vla-getbulge o a)))))
              pc (mapcar (if d '+ '-) pm sd)
              p3 (if
                   (or (equal rad 0.0 1e-8) (eq (cadr opt) "c2"))
                   (if
                     (eq (car opt) "b0")
                     (polar pm (+ (atan (/ (sin u) (cos u))) (/ pi 2.0)) ht)
                     (polar pm (- (atan (/ (sin u) (cos u))) (/ pi 2.0)) (* 1.75 ht))
                     )
                   (if
                     (eq (cadr opt) "c0")
                     (polar pm (angle pm pc) (if (<= 1e-4 (angle pc pm) pi) (* 1.75 ht) ht))
                     (polar pm (angle pc pm) (if (<= 1e-4 (angle pc pm) pi) ht (* 1.75 ht)))
                   )
                 )
               )
        (entmake (list (cons 0 "TEXT") (cons 10 p3) (cons 11 p3) (cons 40 ht) (cons 50 u) (cons 1 (rtos (distance p1 p2) 2 2)) '(7 . "diast") '(8 . "DIM-TEXT") '(73 . 2) '(72 . 1)))
        (setq a (1+ a))
        )
      )
    )
  (vla-endundomark acdoc)
  (princ)


;layer 0
(mapcar 'setvar '("clayer" "cecolor" "celtype" "celweight") (list "0" "BYLAYER" "BYLAYER" -1))
 (princ)
 (c:FText)
 (princ)
);close defun



    
(defun getdictvar (dict var / dict_ename)
  (if
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (cdr (assoc 1 (dictsearch dict_ename var)))
  )
)

(defun setdictvar (dict var val / dict_name record)
  (or
    (setq dict_ename (cdr (assoc -1 (dictsearch (namedobjdict) dict))))
    (setq dict_ename (dictadd (namedobjdict) dict (entmakex '((0 . "DICTIONARY") (100 . "AcDbDictionary")))))
    )
  (if
    (setq record (dictsearch dict_ename var))
    (entmod (subst (cons 1 val) (assoc 1 record) record))
    (dictadd
      dict_ename
      var
      (entmakex
        (list
          '(0 . "DICTIONARYVAR")
          '(100 . "DictionaryVariables")
          '(280 . 0)
          (cons 1 val)
        )
      )
    )
  )
  val
)

;; This code delete duplicate text

(defun c:FText (/ ent ent1 i lst newlayer ofset ss ss1 ss_tmp ans)
  (defun GetBound (ent ofs / ang elist ll lr tb tb1 tb2 ul ur)
    (setq elist	(entget ent)
	  ang	(cdr (assoc 50 elist))
	  tb	(textbox elist)
	  tb1	(car tb)
	  tb2	(cadr tb)
	  ll	(polar (cdr (assoc 10 elist))
		       (+ (angle '(0 0) tb1) ang)
		       (DISTANCE '(0 0) tb1)
		)
	  lr	(polar ll ang (- (car tb2) (car tb1)))
	  ur	(polar ll (+ ang (angle tb1 tb2)) (distance tb1 tb2))
	  ul	(polar ll (+ ang (/ pi 2)) (- (cadr tb2) (cadr tb1)))
    )
    (setq ang (angle ll lr))
    (setq ll (polar ll (- ang (* pi 0.75)) (sqrt (* (* ofs ofs) 2)))
	  lr (polar lr (- ang (/ pi 4)) (sqrt (* (* ofs ofs) 2)))
	  ur (polar ur (+ ang (/ pi 4)) (sqrt (* (* ofs ofs) 2)))
	  ul (polar ul (+ ang (* pi 0.75)) (sqrt (* (* ofs ofs) 2)))
    )
    (list ll lr ur ul)
  )

  (command "_.undo" "be")
  (setq ss (ssget "_X" (list (cons 0 "TEXT")(cons 8 "DIM-TEXT"))) ss1 (ssadd))
  (setq *ofset 0.5)
  (initget 4)
  (if (= ofset nil)
    (setq ofset *ofset)
    (setq *ofset ofset)
  )

  (while (> (sslength ss) 0)
    (setq ent (ssname ss 0)
	  lst (GetBound ent ofset)
    )
    (ssdel ent ss)
    (if	(setq ss_tmp (ssget "cp" lst (list (cons 0 "TEXT"))))
      (progn
	(setq i -1)
	(while (setq ent1 (ssname ss_tmp (setq i (1+ i))))
	  (if (not (equal ent ent1))
	    (progn
	      (ssadd ent1 ss1)
	      (if (ssmemb ent1 ss)
		(ssdel ent1 ss)
	      )
	    )
	  )
	)
      )
    )
  )
    (command ".erase" ss1 "")
    (command "_.undo" "e")
    (princ)
  )

 

test.dwg

[1958]

Multiple selection and removal of duplicates

747.LSP

[Guest]

Hi 1958. I try your code but,

 

1) I use text not mtext

2)The bigger problem is that the half of the dimensions are out of the polygon. I am trying to find a way all the dimension be inside the polygon. All the polyline  in my drawings are counterclockwise.

 

Thanks

[1958]

polyline segment length label (text, non-multiline text)
signatures of common parties are not removed

767.LSP

[Guest]

Thanks 1958