[编程交流] 正位于ano顶部的多段线

;start copy form here
; Loads Visual LISP extensions to AutoLISP
(vl-load-com)
;; this will cll the fiu
(defun C:Dup()
 (duplicateentities)
)
;this is the main function to find duplicate entities/Objects in Autocad
;this is very fast method
;this will catch duplicate entities like Blocks,Point,Line only
;this will not apply for polyline,Lwpolyline
(defun duplicateentities (/ $acad $adoc $mspa ent objname ins bname stp enp lay errcnt)
 (setq    $acad (vlax-get-acad-object)
   $adoc (vla-get-activedocument $acad)
   $mspa (vlax-get-property $adoc 'modelspace)
   errcnt 0
 ) ;_ end of setq
 (vlax-for obj    $mspa
   (setq ent      (vlax-vla-object->ename obj)
     objname (vlax-get-property obj 'objectname)
   ) ;_ end of setq
   (cond
     ((eq objname "AcDbBlockReference")
      (setq ins   (vlax-get obj 'insertionpoint)
        bname (vlax-get obj 'name)
      ) ;_ end of setq
      (if (> (sslength (ssget "x" (list (cons 2 bname) (cons 10 ins)))) 1)
    (progn
      (markerror ent (strcat "Duplicate objects found [" bname "]") nil)
      (setq errcnt (1+ errcnt))
    ) ;_ end of progn
      ) ;_ end of if
     )
     ((eq objname "AcDbPoint")
      (setq ins (vlax-get obj 'Coordinates))
        lay (vlax-get obj 'layer)
      (if (> (sslength (ssget "x" (list (cons 0 "POINT") (cons 10 ins)))) 1)
    (progn
      (markerror ent (strcat "Duplicate objects found [" lay "]") nil)
      (setq errcnt (1+ errcnt))
    ) ;_ end of progn
      ) ;_ end of if
     )
     ((eq objname "AcDbLine")
      (setq stp (vlax-get obj 'startpoint)
        enp (vlax-get obj 'endpoint)
        lay (vlax-get obj 'layer)
      ) ;_ end of setq
      (if (> (sslength (ssget "x" (list (cons 10 stp) (cons 11 enp)))) 1)
    (progn
      (markerror ent (strcat "Duplicate objects found [" lay "]") nil)
      (setq errcnt (1+ errcnt))
    ) ;_ end of progn
      ) ;_ end of if
     )
   ) ;_ end of cond
 ) ;_ end of VLAX-FOR
) ;_ end of defun
;it will mark error (place circle in error layer) in model
(defun markerror (e er f / el etyp handle ip)
 (setq    el     (entget e)
   etyp   (strcase (cdr (assoc 0 el)))
   handle (cdr (assoc 5 el))
   ip     (cond
        ((wcmatch etyp "*LINE")
         (vlax-get-midpoint e)
        )
        (t
         (cdr (assoc 10 el))
        )
          ) ;_ end of cond
 ) ;_ end of setq
 (entmake
   (list (cons 0 "circle") (cons 8 "Error") (cons 10 ip) (cons 62 2) (cons 40 15))
 ) ;_ end of entmake
 (if f
   (write-line (strcat er " For object " handle) f)
 ) ;_ end of if
) ;_ end of defun
;this function will get mid point for LINE,POLYLINE,LWPOLYLINE
(defun vlax-get-midpoint (e / ve)
 (setq ve (vlax-ename->vla-object e))
 (if (= (vlax-curve-getendparam ve) 0)
   (vlax-curve-getstartpoint ve)
   (vlax-curve-getpointatdist
     ve
     (/ (vlax-curve-getdistatparam ve (vlax-curve-getendparam ve)) 2)
   )
 )
) ;_ end of defun