舱口2组
你好我从表单中提取了以下代码行，并尝试进行更改。
我的问题是它并不总是有效。
不幸的是，我看不出为什么它经常有效，也经常无效。
此Lisp应：
图形中有多组对象。
图形已包含一些默认图案填充。
1） 用户选择现有图案填充，然后填充属于不同组的不同区域
用这个图案填充。
2） 当用户完成“_ADDSELECTED”命令后，Lisp应该将每个单独的图案填充添加到他们拥有的组中
封闭。
它经常工作，但并不总是如此！为什么？
请帮忙。
马丁
Lisp程序：
;;----------------------=={ Inside-p }==----------------------;;
;; ;;
;;Predicate function to determine whether a point lies ;;
;;inside a supplied LWPolyline. ;;
;;------------------------------------------------------------;;
;;Author: Lee Mac - www.lee-mac.com ;;
;;Using some code by gile (as marked below), thanks gile. ;;
;;------------------------------------------------------------;;
;;Arguments: ;;
;;pt- 3D WCS point to test ;;
;;ent - LWPolyline Entity against which to test point ;;
;;------------------------------------------------------------;;
;;Returns:T if supplied point lies inside supplied LWPoly ;;
;;------------------------------------------------------------;;
(defun LM:Inside-p (pt ent / _GroupByNum lst nrm obj tmp)
(defun _GroupByNum (l n / r)
(if l
(cons
(reverse (repeat n
(setq r (cons (car l) r)
l (cdr l)
)
r
)
)
(_GroupByNum l n)
)
)
)
(if (= (type ent) 'VLA-OBJECT)
(setq obj ent
ent (vlax-vla-object->ename ent)
)
(setq obj (vlax-ename->vla-object ent))
)
(setq lst
(_GroupByNum
(vlax-invoke
(setq tmp
(vlax-ename->vla-object
(entmakex
(list
(cons 0 "RAY")
(cons 100 "AcDbEntity")
(cons 100 "AcDbRay")
(cons 10 pt)
(cons 11 (trans '(1. 0. 0.) ent 0))
)
)
)
)
'IntersectWith
obj
acextendnone
)
3
)
)
(vla-delete tmp)
(setq nrm (cdr (assoc 210 (entget ent))))
;; gile:
(and
lst
(not (vlax-curve-getparamatpoint ent pt))
(=
1
(rem
(length
(vl-remove-if
(function
(lambda (p / pa p- p+ p0 s1 s2)
(setq pa (vlax-curve-getparamatpoint ent p))
(or
(and (equal (fix (+ pa
(if (minusp pa)
-0.5
0.5
)
)
)
pa
1e-8
)
(setq p-
(cond
((setq p- (vlax-curve-getPointatParam
ent
(- pa 1e-
)
)
(trans p- 0 nrm)
)
((trans (vlax-curve-getPointatParam
ent
(- (vlax-curve-getEndParam ent) 1e-
)
0
nrm
)
)
)
)
(setq p+
(cond
((setq p+ (vlax-curve-getPointatParam
ent
(+ pa 1e-
)
)
(trans p+ 0 nrm)
)
((trans (vlax-curve-getPointatParam
ent
(+ (vlax-curve-getStartParam ent) 1e-
)
0
nrm
)
)
)
)
(setq p0 (trans pt 0 nrm))
(<= 0 (* (sin (angle p0 p-)) (sin (angle p0 p+))))
;; LM Mod
)
(and
(/= 0. (vla-getBulge obj (fix pa)))
(equal
'(0. 0.)
(cdr
(trans (vlax-curve-getFirstDeriv ent pa) 0 nrm)
)
1e-9
)
)
)
)
)
lst
)
)
2
)
)
)
)
(defun c:hatch2group (/ ss i lst pt ent drehwink pt1 as OBJ AWS mypick)
(setq mypick (getvar "pickstyle"))
(setvar "pickstyle" 0)
(setq OBJ (entlast))
(command "_ADDSELECTED"
Pause
(setq pt1 (getpoint "\nPick Point: "))
)
(while (/= (getvar "CMDACTIVE") 0) (command pause))
(setq AWS (ssadd))
(while (setq OBJ (entnext OBJ)) (ssadd OBJ AWS))
(sssetfirst AWS AWS)
(setq as (entlast))
(if
(and (setq ss (ssget "_X" '((0 . "LWPOLYLINE"))))
(repeat (setq i (sslength ss))
(setq lst (cons (ssname ss (setq i (1- i))) lst))
)
(setq pt pt1)
)
;(if
(setq ent
(car
(vl-member-if
(function
(lambda (x) (LM:Inside-p (trans pt 1 0) x))
)
lst
)
)
)
;(vla-put-color (vlax-ename->vla-object ent) acRed)
)
(princ)
(command "_groupedit" ent "H" AWS "")
(while (/= (getvar "CMDACTIVE") 0) (command pause))
(setvar "pickstyle" mypick)
(princ)
)
(princ)
页:
[1]