[LISP函数]：返回块上距离指定点最近的点

小菜

这是我根据别的函数改过来的，由于对Vlisp不熟悉，函数只能得到距Curve类子实体最近的点，哪位大虾能改成可支持其它如Hatch、Text、Attib等子实体呢？

2. 
   
3.   [FONT=courier new]
   
4. ;GetBlockNea   ---返回点距块内每个子实体最近的点
   
5. ; 测试：(GetBlockNea (vlax-ename->vla-object (car (entsel))) (getpoint) acExtendNone)
   
6. ;暂时仅支持Curve类子实体
   
7. ; Arguments [Typ]:
   
8. ;   Blk = Block object [VLA-OBJECT]
   
9. ;   Pt1 = Point [LIST]
   
10. ;   Mde = Intersection mode [INT]
    
11. ;         Constants:
    
12. ;         - acExtendNone           Does not extend either object.
    
13. ;         - acExtendThisEntity     Extends the Fst object.
    
14. ;         - acExtendOtherEntity    Extends the Nxt object.
    
15. ;         - acExtendBoth           Extends both objects.
    
16. ; Return [Typ]:
    
17. ;   > list of points '((1.0 1.0 0.0)... [LIST]
    
18. ;   > Nil if not found
    
19. ; Notes:
    
20. ;   None
    
21. ;
    
22. (defun GetBlockNea (Blk Pt1 Mde / ObjNme PntLst TmpVal Pt2 dst1 Pt3 )
    
23. (foreach memb (vlax-invoke Blk "Explode")
    
24.   (setq ObjNme (vla-get-ObjectName memb))
    
25.   (cond
    
26.    ((or
    
27.      (and
    
28.       (eq ObjNme "AcDbHatch")
    
29.       (eq (strcase (vla-get-PatternName memb)) "SOLID")
    
30.      )
    
31.      (eq ObjNme "AcDb3dSolid")
    
32.      (eq ObjNme "AcDbAttributeDefinition")
    
33.     )
    
34.    )
    
35.    ((eq ObjNme "AcDbBlockReference")
    
36.     (if (setq TmpVal (GetBlockNea memb Pt1 Mde))
    
37.      (setq PntLst (append PntLst TmpVal))
    
38.     )
    
39.    )
    
40.    ((wcmatch ObjNme "AcDbPolyline,AcDbEllipse,AcDbCircle,AcDbArc,AcDbLine,AcDbPolyline")
    
41.    ;;(T     
    
42.     (if (setq TmpVal (vlax-curve-getclosestpointto memb Pt1 Mde))
    
43.      (setq PntLst (cons TmpVal PntLst))
    
44.     )
    
45.    )
    
46.   )
    
47.   (vla-Delete memb)
    
48. )
    
49.   (if PntLst
    
50.      (progn
    
51.        (setq Pt3 (car PntLst) dst1 (distance Pt1 pt3))
    
52.        (foreach Pt2 PntLst
    
53.              (if (< (distance Pt1 Pt2) dst1) (setq Pt3 Pt2 dst1 (distance Pt1 Pt2)))
    
54.         )
    
55.      )
    
56.   )
    
57. Pt3
    
58. )  ;end of defun
    
59.   [/FONT]
    

<br />   [FONT=courier new]<br /> ;GetBlockNea   ---返回点距块内每个子实体最近的点<br /> ; 测试：(GetBlockNea (vlax-ename->vla-object (car (entsel))) (getpoint) acExtendNone)<br /> ;暂时仅支持Curve类子实体<br /> ; Arguments [Typ]:<br /> ;   Blk = Block object [VLA-OBJECT]<br /> ;   Pt1 = Point [LIST]<br /> ;   Mde = Intersection mode [INT]<br /> ;         Constants:<br /> ;         - acExtendNone           Does not extend either object.<br /> ;         - acExtendThisEntity     Extends the Fst object.<br /> ;         - acExtendOtherEntity    Extends the Nxt object.<br /> ;         - acExtendBoth           Extends both objects.<br /> ; Return [Typ]:<br /> ;   > list of points '((1.0 1.0 0.0)... [LIST]<br /> ;   > Nil if not found<br /> ; Notes:<br /> ;   None<br /> ; <br /> (defun GetBlockNea (Blk Pt1 Mde / ObjNme PntLst TmpVal Pt2 dst1 Pt3 )<br /> (foreach memb (vlax-invoke Blk "Explode")<br />   (setq ObjNme (vla-get-ObjectName memb))<br />   (cond<br />    ((or<br />      (and<br />       (eq ObjNme "AcDbHatch")<br />       (eq (strcase (vla-get-PatternName memb)) "SOLID")<br />      )<br />      (eq ObjNme "AcDb3dSolid")<br />      (eq ObjNme "AcDbAttributeDefinition")<br />     )<br />    )<br />    ((eq ObjNme "AcDbBlockReference")<br />     (if (setq TmpVal (GetBlockNea memb Pt1 Mde))<br />      (setq PntLst (append PntLst TmpVal))<br />     )<br />    )<br />    ((wcmatch ObjNme "AcDbPolyline,AcDbEllipse,AcDbCircle,AcDbArc,AcDbLine,AcDbPolyline")<br />    ;;(T     <br />     (if (setq TmpVal (vlax-curve-getclosestpointto memb Pt1 Mde))<br />      (setq PntLst (cons TmpVal PntLst))<br />     )<br />    )<br />   )<br />   (vla-Delete memb)<br /> )<br />   (if PntLst <br />      (progn<br />        (setq Pt3 (car PntLst) dst1 (distance Pt1 pt3))<br />        (foreach Pt2 PntLst <br />              (if (< (distance Pt1 Pt2) dst1) (setq Pt3 Pt2 dst1 (distance Pt1 Pt2)))<br />         )<br />      )<br />   )<br /> Pt3<br /> )  ;end of defun<br />   [/FONT]<br />

eachy

不用Explode，把点转换成相对块的OCS，然后遍历块内实体即可。

其他实体要订个规则才可以，比如Text，ATT用插入点还是BOX的最近点，Hatch是否用分解后实体等等。

小菜

"把点转换成相对块的OCS，然后遍历块内实体即可"这个做法我不会，试了几次都没能把点的坐标变换搞对，遍历块内实体得到的子实体怎么获得与已知点最近的点也是个问题，似乎vlax-curve-getclosestpointto 函数也不好用，eachy兄能否提供一个例子呢？
Text等可以下一步再考虑，Hatch还是用分解后的实体比较好，但不知道为什么vlax-invoke Blk "Explode" 对Hatch无效

aeo

最初由 eachy 发布
[B]不用Explode，把点转换成相对块的OCS，然后遍历块内实体即可。

其他实体要订个规则才可以，比如Text，ATT用插入点还是BOX的最近点，Hatch是否用分解后实体等等。 [/B]

恐怕不行,比如:
arc在x y不同比例的情况下变成了椭圆，没办法求的.
(块内是arc,而explode后是椭圆)

陌生人

楼上言之有理。
另，对text求实体包围盒，对hatch求边界（不推荐炸开），对3dsolid还没想到好办法。

小菜

这个程序是我的一个程序的子函数，其实我并不需要对TEXT等子实体求最近点，但对Hatch，却是需要Explode后的才行，所以还是希望修改(vlax-invoke Blk "Explode")，让它支持对Hatch的打碎，只是我不会改，哪位能帮个忙呢？

eachy

最初由 小菜 发布
[B]这个程序是我的一个程序的子函数，其实我并不需要对TEXT等子实体求最近点，但对Hatch，却是需要Explode后的才行，所以还是希望修改(vlax-invoke Blk "Explode")，让它支持对Hatch的打碎，只是我不会改，哪位能帮个忙... [/B]

Autodesk 没有提供Hatch 的Explode方法，只能用命令打碎块，最后Undo回去，这样作为子函数可能有问题。

陌生人

那可以拷贝一份来炸啊，求完了删除

小菜

有没有办法加到上面的函数中呢？
后来想了一下，好象比较麻烦，可能要重写函数了

434939575

这个挺好的。收藏了。谢谢！