Red de conocimiento informático - Computadora portátil - En CAD, interrumpa el programa LISP en todas las intersecciones a la vez. Gracias. Mi correo electrónico es 313013264@qq.com.

En CAD, interrumpa el programa LISP en todas las intersecciones a la vez. Gracias. Mi correo electrónico es 313013264@qq.com.

;; función principal

(defun c:MBB (/elist ssg n t0)

(VL-LOAD-COM)

(setq t0 (xdl- getutime))

(if (setq ssg (ssget '((0 ."line,arc,circle,ellipse"))))

(vlax-for obj (vla- get-activeselectionset

(vla-get-activedocument (vlax-get-acad-object))

)

(setq elist (cons obj elist)) ssg->elist

)

)

(DoEntMake (InterSort (ssinter elist)))

(princ ( strcat) "\n***** encontrar intersección"

(itoa n)

"Uno, la operación de desconexión de intersección *** lleva tiempo"

(rtos (- (xdl-getutime) t0) 2 3)

"sec.*****"

)

)

(princ)

)

;;Encontrar la función de conjunto de intersecciones - nth

;;Después de la prueba, la enésima función es solo un poco más rápida que la función assoc.

;; Por lo tanto, esta función también puede cancelar las variables i y j y usar directamente la función asociada

(defun ssinter (el / el1 obj1 obj2 ipts pts list1 outlst i j )

(setq outlst (mapcar 'list el)

i -1 ;puntero a la ubicación de obj1

n 0 ;

(mientras el

(setq obj1 (car el)

list1 (nth (setq i (1+ i)) outlst); lista de intersecciones que obj1 ya tiene

el (cdr el)

el1 el

j i ; puntero a la ubicación de obj2

)

(mientras el1

(setq obj2 (car el1)

el1 (cdr el1)

j (1+ j)

)

> ;; Tomar intersección

(if (y (setq ipts (vla-intersectwith obj1 obj2 0))

(setq ipts (vlax-variant-value ipts) )

(>(vlax-safearray-get -u-bound ipts 1) 0)

)

(pro

gn

(setq ipts (vlax-safearray->list ipts)

pts '() ;obj1,obj2 intersectan variables de lista temporales

)

( while (> (longitud ipts) 0)

(setq pts (cons (lista (car ipts))

(cadr ipts)

(caddr ipts)

)

pts

)

ipts (cdddr ipts)

)

(setq list1 (append list1 pts) ; almacena la lista de intersecciones de obj1 y la actualiza al final del ciclo

n (+ n (length pts)) ; la intersección el recuento se acumula

)

;; La lista de intersecciones de obj2 se actualiza inmediatamente

(setq

outlst (subst (append ( nth j outlst) pts)

(nth j outlst)

outlst

)

)

)

)

)

;;; Cuando hay una intersección en obj1 y no es una curva cerrada, agrega dos puntos finales

(if (y (cdr list1) (not (vlax-curve-isClosed obj1)))

(setq list1 (append list1

( list (vlax-curve-getEndPoint obj1 ))

(lista (vlax-curve-getStartPoint obj1))

)

)

)

(setq outlst (subst list1 (nth i outlst) outlst)); actualizar obj1 lista de intersecciones

)

outlst

)

;

; ; Clasificación de conjuntos de puntos y eliminación de funciones de puntos duplicados

(defun InterSort (el / obj1 pts plst outlst)

(setq outlst '( )) ; Lista vacía

(foreach elemento el

(setq obj1 (elemento de automóvil)

pts (elemento cdr)

plst '()) ;lista vacía

)

(if pts ;Si no hay intersección, la entidad no se modifica

(progn

;;Clasificación de intersecciones, la lista se invierte

(setq

pts (vl-sort

pts

(función (lambda (p1 p2)

(<(vlax-curve-getParamAtPoint obj1 p1)

(vlax-curve-getParamAtPoint obj1 p2)

)

)

)

)

)

)

; Eliminar puntos duplicados e invertir el orden de la lista

p>

(fo

alcanzar pts

(if plst

(if (no (igual p (car plst) 0.00001))

(setq plst (cons p plst))

)

)

( setq plst (cons p plst))

)

)

;;;El primer punto de intersección debe agregarse a la curva cerrada para que la nueva entidad esté completamente cerrada

(if (vlax-curve-isClosed obj1)

(setq plst (cons (last plst) plst))

)

(setq plst (cons (vlax-vla-object->ename obj1) plst)

outlst (contras plst outlst)

)

)

)<

)

outlst

)

;;Llame a entmake para generar nuevas entidades

(defun DoEntMake (el / obj objlst objname objcen objratio objaxis)

(foreach e el

(setq obj (car e)

objlst (entget obj)

objlst (vl-remove (assoc -1 objlst) objlst) ; eliminar elemento Nombre del grupo

objlst (vl-remove (assoc 330 objlst) objlst); eliminar id

objlst (vl-remove (assoc 5 objlst) objlst); eliminar identificador

nombreobj (cdr (assoc 0 objlst))

)

(cond

((= nombreobj "LINE")

(repetir (- (longitud e) 2)

)

(setq objlst (subst (cons 51 (ángulo objcen (cuidado))))

(objlst asociado 51)

objlst

)

)

(objlst entmake)

)

p>

(entdel obj)

)

((= nombreobj "ARC")

(setq objcen (cdr ( assoc 10 objlst)) )

(repeat (- (longitud e) 2)

(setq objlst (subst (cons 42 (pt-> param (car e) objcen objaxis objratio))

p>

(assoc 42 objlst)

objlst

)

)

( entmake objlst)

)

(entdel obj)

)

)

)

)

)

;; Calcular el tiempo transcurrido

(defun xdl-getutim

e ()

(* 86400 ( getvar "tdusrtimer"))

)

;; Buscar parámetros de curva elíptica

(defun pt->param (pt relación eje cen / ang parámetro)

(setq ang (- (ángulo cen pt) (ángulo ' (0.0. 0. 0.) eje)))

(cond ((= (cos ang) 0.0) ;evita errores si el denominador cos es cero

(if (> (sin ang) 0.0)

(setq param (* 0,5 PI))

(setq param (* 1,5 PI))

)

)

((= (sin ang) 0.0)

(if (> (cos ang) 0.0)

(setq param 0.0)

(setq param PI)

)

)

)

(T

(setq param (atan (/ (sin ang) (* (cos ang) ratio))))

(if (< (cos ang) 0.0)

(setq param (+ pi param)

)

)

)

param

)

(princ)

Mira esto