关于画垂线的，哪位大佬给优化一下啊，拜托了
本帖最后由 xj6019 于 2019-12-17 22:37 编辑以下代码是两个命令，一个是画垂线的，一个是画中垂线的，最理想的是把两个命令合成一个，留个选项可以键值切换，默认垂线，能识别普通直线，构造线，块中的直线，多段线，尺寸线
运行时，普通垂线时先选择直线，然后提示垂足通过的点，中垂线时输入键值直接出结果
垂线的长度，可以用xline也可以是线，长度放的长点就行，100000就够了,默认当前图层，这些就够了，谢谢！！！
(defun c:cx()
(setvar "CMDECHO" 0)
(if (setq s1 (entsel "\n選取直線:")) (progn
(setq pt (cadr s1)
pt2 (osnap pt "NEAR")
pt1 (polar pt2 (angle pt2 pt) 900)
pt3 (polar pt2 (angle pt pt2) 900)
pt4 (polar pt1 (angle pt pt2) -150)
pt5 (polar pt3 (angle pt2 pt) -150))
(command "PLINE" pt4pt1 pt3 pt5 "")
))
(setvar "CMDECHO" 1)
(princ)
)
(defun C:ZC (/ ENT P1 P2 MP AN DI)
(setq ENT (entsel "\n選取直線:")
ENT (entget (car ENT))
P1(cdr (assoc 10 ENT))
P2(cdr (assoc 11 ENT))
MP(mapcar '(lambda (X Y) (/ (+ X Y) 2.)) P1 P2)
AN(+ (angle P1 P2) (/ PI 2.))
DI(/ (distance P1 P2) 2.)
)
(entmake (list '(0 . "LINE")
(cons 10 (polar MP AN DI))
(cons 11 (polar MP AN (- DI)))
))
)
本帖最后由 caiqs 于 2019-12-18 22:24 编辑
;;;师兄QQ361865648
;;;好人做到底，送佛送到西，好吧，现在块可以使用了，尺寸也可以了，不过要多响应一次;;再要如何你自已弄了，浪费我太多时间，应该是你要的效果了
(vl-load-com)
(defun cxfun (ent / ename pickpt ponl ang p1 p2 entdat etype pt)
(setq ename (car ent))
(setq entdat(entget ename)
etype(cdr(assoc 0 entdat)))
(setq pickpt (cadr ent))
(cond
((member etype
'("CIRCLE" "ELLIPSE" "RAY" "LINE" "XLINE" "SPLINE"
"LWPOLYLINE")
)
(setq ponl (vlax-curve-getClosestPointTo ename pickpt))
)
(t (setq ponl (osnap pickpt "_nea"))))
(setq ang (angle pickpt ponl))
(setq pt(VL-CATCH-ALL-APPLY 'getpoint (list "\n指定垂足点: ")))
(if (and pt (not (VL-CATCH-ALL-ERROR-P pt)))
(setq p1(polar pt ang 1000)
p2(polar pt (+ ang pi) 1000))
(setq p1 (polar ponl ang 1000)
p2 (polar ponl (+ ang PI) 1000)
)
)
(entmake (list '(0 . "LINE")
(cons 10 p1)
(cons 11 p2)
)
)
(princ)
)
(defun c:cx (/ ent)
(setq ent (entsel "\n選取直線:"))
(vl-CATCH-ALL-APPLY 'cxfun '(ent))
(princ)
)
(defun ZCfun (ent / ename pickpt ponl ang p1 p2 entdat etype)
(setq ename (car ent))
(setq entdat(entget ename)
etype(cdr(assoc 0 entdat)))
(setq pickpt (cadr ent))
(cond
((member etype
'("CIRCLE" "ELLIPSE" "RAY" "LINE" "XLINE" "SPLINE"
"LWPOLYLINE")
)
(setq ponl (vlax-curve-getClosestPointTo ename pickpt))
)
(t (setq ponl (osnap pickpt "_nea"))))
(setq midp (osnap ponl "_mid")) ;_中点
(setq ang (angle pickpt ponl))
(setq p1 (polar midp ang1000)
p2 (polar midp (+ ang PI)1000)
)
(entmake (list '(0 . "LINE")
(cons 10 p1)
(cons 11 p2)
)
)
)
(defun c:ZC (/ ent)
(setq ent (entsel "\n選取直線:"))
(vl-CATCH-ALL-APPLY 'Zcfun '(ent))
(princ)
)
(defun c:test (/ mystr k str mod ent mod)
(setq mystr (list "中垂线" "一般垂线")
k 0
str (nth k mystr)
mod t
)
(while mod
(setq ENT (VL-CATCH-ALL-APPLY
'entsel
(list (strcat "\n選取直線 <" str "> :"))
)
)
(if
(not (VL-CATCH-ALL-ERROR-P ent))
(cond
((null ent) (setq k (- 1 k)))
(t
(if (= k 0)
(VL-CATCH-ALL-APPLY 'ZCfun (list ent))
(VL-CATCH-ALL-APPLY 'cxfun (list ent))
)
)
)
(setq mod nil)
)
(setq str (nth k mystr))
)
(princ)
)
本帖最后由 caiqs 于 2019-12-17 22:32 编辑
;;;师兄QQ361865648,用A键切换中垂线和一般垂线
(defun c:ts1 (/ ang endptentdat entpick ept etype
inpt intptlen midp midpt mode osptsp1
p2 pt ret sortlst startpt x
y
)
(while (and (setq entpick (entsel "\n選取直線 :"))
(setq entdat (entget (car entpick)))
(setq etype (cdr (assoc 0 entdat)))
(= etype "LINE")
)
(setq startpt (cdr (assoc 10 entdat))
endpt (cdr (assoc 11 entdat))
midpt (getmidpt startpt endpt)
len (DISTANCE startpt endpt)
ang (angle startpt endpt)
mode nil
)
(while (and
(setq ret (grread t 12))
(member (car ret) '(2 5))
)
(redraw)
(cond
((= (car ret) 2) (setq mode (not mode)))
((= (car ret) 5)
(setq pt (cadr ret))
(setq intpt (getprep startpt endpt pt))
;;如果离中点很近则自动为中垂线
;;; (if (< (DISTANCE intpt midpt) (* 0.01 len))
;;; (setq intpt midpt))
(if mode
(progn
(setq midp (osnap intpt "_mid"))
(setq inpt (osnap intpt "_int"))
(setq ept (osnap intpt "_end"))
(setq ospts nil)
(if midp
(setq ospts (cons midp ospts))
)
(if inpt
(setq ospts (cons inpt ospts))
)
(if ept
(setq ospts (cons ept ospts))
)
(setq sortlst nil)
(if ospts
(setq sortlst
(vl-sort ospts
'(lambda (x y)
(<= (DISTANCE x intpt) (DISTANCE y intpt))
)
)
)
)
(if sortlst
(setq intpt (car sortlst))
)
)
)
)
)
(setq p1 (polar intpt (+ ang (* 0.5 PI)) (* 0.5 len))
p2 (polar intpt (- ang (* 0.5 pi)) (* 0.5 len))
)
(grdraw p1 p2 3)
)
(redraw)
(if (= (car ret) 3)
(entmake (list '(0 . "LINE")
(cons 10 P1)
(cons 11 P2)
)
)
)
)
)
caiqs 发表于 2019-12-17 22:03
;;;师兄QQ361865648,用A键切换中垂线和一般垂线
(defun c:ts1 (/ ang endptentdat entpick ept...
您好老师，首先谢谢您的热心解答，您的想法虽然很新颖，但是与我的本意还是差了点
1，垂线生成预览后无法捕捉，虽然可以自由移动，但是有点过于自由了，想要放到某一个点还得手动移动一下，希望可以完善。
2.最最最重要的，我经常需要对构造线，多段线，尺寸线，图块里面的某根线做垂线，目前您的代码还是不行，这次求助主要想解决这个问题，如果不是解决这个问题，对普通直线，之前那代码是完全够我用的。
再次麻烦一下呗，把您的代码可否完善一下呀，谢谢！！ 本帖最后由 xyp1964 于 2019-12-18 13:04 编辑
(defun c:cx ()
(setq ukw (Ukword 1 "1 2" "1-垂线/2-中垂线" ukw))
(while (setq s1 (entsel "\n选线: "))
(setq pt (cadr s1)
p2 (osnap pt "near")
rr (angle pt p2)
p2 (if (= ukw "1") p2 (osnap pt "mid"))
p1 (polar p2 rr 1000)
p3 (polar p2 rr -1000)
)
(command "line" "non" p1 "non" p3 "")
)
(princ)
)
(defun ukword (bit kwd msg def / inp)(if (and def (/= def ""))
(setq msg (strcat "\n" msg "<" def ">: ")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
)
(initget bit kwd)
(setq inp (getkword msg))
(if inp inp def)
) xyp1964 发表于 2019-12-18 00:54
抽空给你看看吧，我那个能捕捉的，只是你没有试 xj6019 发表于 2019-12-17 22:45
您好老师，首先谢谢您的热心解答，您的想法虽然很新颖，但是与我的本意还是差了点
1，垂线生成预览后无 ...
抽空给你看看，我那个能捕捉，你没有试一下吗? caiqs 发表于 2019-12-18 07:37
抽空给你看看，我那个能捕捉，你没有试一下吗?
我特意试了，可能没领会到怎么捕捉技巧吧，还有别的方式吗，正常情况没有捕捉哦，主要还是特殊情况下（非普通直线）的使用问题，谢谢您的回复！ xyp1964 发表于 2019-12-18 00:54
谢谢版主，您的代码说实在的都是关联函数，我每次看到都头疼，因为知道您的函数简洁好用，但是无奈我没法用工具箱（系统非中文）也就没法用您的一系列函数库，有兴趣搞搞多国语言版，或者研究一下能支持非中文系统支持也行哦，所以，您给的回复我也又只能望洋兴叹了，非常感谢您的回复！
这次是缺UKWORD！！！ xj6019 发表于 2019-12-18 08:11
我特意试了，可能没领会到怎么捕捉技巧吧，还有别的方式吗，正常情况没有捕捉哦，主要还是特殊情况下（非 ...
恩明白你的意思了，晚上给你改一下吧