离曲线端点 指定距离d 插入块
本帖最后由 自贡黄明儒 于 2022-12-23 15:15 编辑千古文章多闲话，论坛多废贴，我为论坛废贴添砖加瓦:lol
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;离曲线d 插入块
;;164.23 [功能] 多段线所击点离起点近
;;示例(HH:PickToStart (car(setq en(entsel))) (cadr en))
(defun HH:PickToStart (curve p / L1 L2 PP)
(setq pp (vlax-curve-getclosestpointto curve (trans p 1 0)))
(setqL2 (vlax-curve-getDistAtParam curve
(vlax-curve-getEndParam curve)
)
)
(setq L1 (vlax-curve-getDistAtPoint curve pp))
(> (- L2 L1) L1)
)
(defun _HH:MyI (e d name / ANG ANGB ECURVE P P0 PARAM PRCS)
(setq p0 (cadr e))
(if (= (length e) 4)
(progn
(setq angB (cdr (assoc 50 (entget (car (last e))))));块转角
(setq prcs (MAT:TransNested p0 (last e) 1 2)) ;将点用户转换到块坐标系 By highflybird
(setq Ecurve (car e)) ;块内图元
(setq prcs (vlax-curve-getClosestPointTo Ecurve prcs))
;;计算击点离终点近还是起点近
(if (HH:PickToStart Ecurve prcs)
(setq p (vlax-curve-getPointAtDist Ecurve d))
(setq
p (vlax-curve-getPointAtDist Ecurve
(- (vlax-curve-getDistAtParam Ecurve
(vlax-curve-getEndParam Ecurve)
)
d
)
)
)
)
;;Z坐标归0,不然后算出来的角度不对
(setq prcs (mapcar '+ '(0 0) p))
(setq Param (vlax-curve-getParamAtPoint Ecurve prcs))
(setq ang (angle '(0 0) (vlax-curve-getFirstDeriv Ecurve param)))
(setq ang (+ ang angB))
;;离曲线d0的点，从块中转出来
(setq p (MAT:TransNested prcs (last e) 2 1))
)
(progn
(setq Ecurve (car e))
(setq prcs (vlax-curve-getClosestPointTo Ecurve (cadr e)))
(if (HH:PickToStart Ecurve prcs)
(setq p (vlax-curve-getPointAtDist Ecurve d))
(setq
p (vlax-curve-getPointAtDist Ecurve
(- (vlax-curve-getDistAtParam Ecurve
(vlax-curve-getEndParam Ecurve)
)
d
)
)
)
)
(setq prcs (mapcar '+ '(0 0) p))
(setq Param (vlax-curve-getParamAtPoint Ecurve prcs))
(setq ang (angle '(0 0) (vlax-curve-getFirstDeriv Ecurve param)))
)
)
;;1 插入块
(entmake (list '(0 . "INSERT")
(cons 2 name)
(cons 10 p)
(cons 50 Ang)
(cons 8 "0")
(cons 41 1)
(cons 42 1)
(cons 43 1)
)
)
;;2 旋转块
((if command-scommand-s vl-cmdf) "._rotate" (entlast) "" "non" p pause)
(princ "\n 插入块 MyI")
)
(defun C:MyI (/ D D0 E EN MYI NAME NAME0)
((if command-scommand-s vl-cmdf) "_.ucs" "_w")
(if (setq MyI (GETENV "HuangMR\\MyI"));(sETENV "HuangMR\\MyI" "")
(progn
(setq MyI (read MyI))
(setq d0 (car MyI))
(setq name0 (cdr MyI))
)
)
(if d0
(setq d (getreal (strcat "\n 块插入距离<" (vl-princ-to-string d0) ">:")))
(setq d (getreal "\n 块插入距离:"))
)
(if d
(setq d0 d)
(setq d d0)
)
(if (setq e (LM:ssget "\n 拾取块名:" '("_+.:E:S" ((0 . "INSERT")))))
(progn
(setq e (ssname e 0))
(setq en (entget e))
(setq name (cdr (assoc 2 en)))
)
(ifname0
(setq name (getstring (strcat "\n 块名<" name0 ">:")))
(setq name (getstring "\n 块名:"))
)
)
(if (/= name "")
(setq name0 name)
(setq name name0)
)
(if (and d name (/= name ""))
(progn
(setenv "HuangMR\\MyI" (vl-prin1-to-string (cons d name)))
(if (and (tblobjname "BLOCK" name) (setq e (nentsel "\n 点取曲线:")))
(_HH:MyI e d name)
)
)
)
(princ)
)
;;离曲线d 插入块
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; 以上实际 是我写的第二版，解决了画桁架上插入块的问题。实用上还是不方便，最后仿命令I，感觉好多了 自贡黄明儒 发表于 2022-12-24 08:33
以上实际 是我写的第二版，解决了画桁架上插入块的问题。实用上还是不方便，最后仿命令I，感觉好多了
大佬，第二版也分享下呗 真不错！很好 自贡黄明儒 发表于 2022-12-24 08:33
以上实际 是我写的第二版，解决了画桁架上插入块的问题。实用上还是不方便，最后仿命令I，感觉好多了
黄大师太强了～
不知道有没有得分享呢？
页:
[1]