Gu_xl 发表于 2011-10-21 00:04
没有必要打开线宽吧
Gu_xl 发表于 2011-10-21 00:04
感觉开了线宽，CAD运行就慢了很多。
Gu_xl 发表于 2011-10-21 00:04
是我想要的！还能90° 180°旋转调整，简直神器！
非常好，如果能复制（不移动），还能不自动关闭捕捉，那就是十分完美了！
依然小小鸟 发表于 2018-8-19 21:46
能增加框选的功能吗？楼主 我看你最近还在上论坛 民众的呼声啊 希望你能看到增加框选对象功能 谢谢楼 ...
里面加个变量就可以
loveu515 发表于 2023-7-13 13:10
里面加个变量就可以
我不会写代码:'(:'(:'(
依然小小鸟 发表于 2023-7-13 13:51
我不会写代码
我也不会啊
;;;;;;;物体（文字、曲线、块）与线平齐;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;BY yjr111 2011-10-25;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun c:yxpq(/ e1 e2 ee eee s11p11 ang1 ang2 an lst11 JIAODU1JIAODU2 JIAODU3 ss)
(vl-load-com)
(setvar "cmdecho" 0)
(setq e1 (car(setq ee(nentselp"\n 请选择要对齐的边："))))
(setq s11 (entget e1))
(princ "\n请选择要对齐的全部图元:")
(setq ss (ssget))
(if (wcmatch(cdr(assoc 0 s11))"*TEXT")
(progn
(setq p11 (cdr(assoc 10 s11)))
(setq ang1 (cdr(assoc 50 s11))))
(progn
(setq lst11(nentselp (setq p11(cadr ee))))
(qvxianjiaodu lst11 )
(setq ang1 an))
)
(SETQ JIAODU1 (* (/ ang1 PI)180))
(setq an nil)
(setq e2 (car(setq eee(nentselp"\n 请选择物体要对齐的曲线"))))
(setq lst11(nentselp (cadr eee)))
(qvxianjiaodu lst11 )
(setq ang2 an)
(SETQ JIAODU2 (* (/ ang2 PI)180))
(setq an nil)
;;;;;;;;;;;;;;旋转平移;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(IF (> (LENGTH ee)2) (PROGN (SETQ e1 (CAAR (REVERSE ee)))
(setq p11 (cdr(assoc 10 (ENTGET e1)))
jiaodu3 (*(/(cdr(assoc 50 (ENTGET e1)))PI)180))))
(setq jiaodu (- jiaodu2 jiaodu1))
(cond
((and(and e1 e2)(> (LENGTH ee)2))
(command "_.rotate" ss "" p11 (- jiaodu jiaodu3))
(command"_.MOVE" ss ""p11pause))
(t(command "_.rotate" ss "" p11 jiaodu )
(command"_.MOVE" ss ""p11pause))
)
(princ)
)
;;;;;;;;;;;;;引用highflybir的块切线的大部分代码,qvxianjiaodu部分有修改，在此致谢！;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun qvxianjiaodu (lst11 /Bs en LST11 m ppP1 P2 P3 P4 P5 P6 vt rt D L S)
(defun CheckIsCurve(en / dxf typ) ;检查是否是曲线
(and
en ;存在实体
(setq dxf (entget en)) ;DXF码
(setq typ (cdr (assoc 0 dxf))) ;图元类型
(or (member typ '("ELLIPSE" "CIRCLE" "ARC" "RAY"))
(wcmatch typ "*LINE")
)
)
)
(if lst11 (progn ;;;原程序为while p0
(setq en (car lst11)) ;光标处图元
(if (CheckIsCurve en)
(setq P12 (cadr lst11) ;光标点
m(caddr lst11) ;变换矩阵
Bs (cadddr lst11) ;块参照列表(可能有嵌套)
P1 (TransNested P12 Bs 1 2) ;把点变换到图块坐标系
P1 (vlax-curve-getclosestpointto en P1) ;得到最近点
pp (vlax-curve-getParamAtPoint en P1) ;得到这点参数
vt (vlax-curve-getFirstDeriv en pp) ;得到切线
an (angle '(0 0 0) vt) ;切线角
)
(princ "\n你没点中或者此处不是曲线类物体!")
)
))
(princ)
)
;;; 矢量的点积
;;; VXV Returns the dot product of 2 vectors
(defun vxv (v1 v2)
(apply '+ (mapcar '* v1 v2))
)
;;; 矢量转置
;;; TRP Transpose a matrix -Doug Wilson-
(defun trp (m)
(apply 'mapcar (cons 'list m))
)
;;; 矢量的矩阵变换
;;; MXV Apply a transformation matrix to a vector -Vladimir Nesterovsky-
(defun mxv (m v)
(mapcar (function (lambda (r) (vxv r v))) m)
)
;;; 点到矩阵的变换
(defun mxp (m p)
(reverse (cdr (reverse (mxv m (append p '(1.0))))))
)
;;; 矩阵相乘
;;; MXM Multiply two matrices -Vladimir Nesterovsky-
(defun mxm (m q)
(mapcar (function (lambda (r) (mxv (trp q) r))) m)
)
;;;位移变换
(defun translation (mat vec)
(mapcar (function
(lambda (x y)
(list (car x) (cadr x) (caddr x) (+ (cadddr x) y))
)
)
mat
vec
)
)
;;;两矢量的叉积
;;; Vector Cross Product - Lee Mac
;;; Args: u,v - vectors in R^3
(defun v^v ( u v )
(list
(- (* (cadr u) (caddr v)) (* (cadr v) (caddr u)))
(- (* (carv) (caddr u)) (* (caru) (caddr v)))
(- (* (caru) (cadrv)) (* (carv) (cadru)))
)
)
;; TransNested (gile)
;; Translates a point coordinates from WCS or UCS to RCS -coordinates system of a
;; reference (xref or block) whatever its nested level-
;;
;; Arguments
;; pt : the point to translate
;; rlst : the parents entities list from the deepest nested to the one inserted in
;; current space -same as (last (nentsel)) or (last (nentselp))
;; from to : as with trans function: 0 for WCS, 1 for current UCS, 2 for RCS
(defun TransNested (pt rlst from to)
(and (= 1 from) (setq pt (trans pt 1 0)))
(and (= 2 to) (setq rlst (reverse rlst)))
(and (or (= 2 from) (= 2 to))
(while rlst
(setq geom (if(= 2 to)
(RevRefGeom (car rlst))
(RefGeom (car rlst))
)
rlst (cdr rlst)
pt (mapcar '+ (mxv (car geom) pt) (cadr geom))
)
)
)
(if (= 1 to)
(trans pt 0 1)
pt
)
)
;; RefGeom (gile)
;; Returns a list which first item is a 3x3 transformation matrix (rotation,
;; scales, normal) and second item the object insertion point in its parent
;; (xref, bloc or space)
;;
;; Argument : an ename
(defun RefGeom (ename / elst ang norm mat)
(setqelst (entget ename)
ang(cdr (assoc 50 elst))
norm (cdr (assoc 210 elst))
)
(list
(setq mat
(mxm
(mapcar (function (lambda (v) (trans v 0 norm T)))
'((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
)
(mxm
(list (list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(list (list (cdr (assoc 41 elst)) 0.0 0.0)
(list 0.0 (cdr (assoc 42 elst)) 0.0)
(list 0.0 0.0 (cdr (assoc 43 elst)))
)
)
)
)
(mapcar
'-
(trans (cdr (assoc 10 elst)) norm 0)
(mxv mat
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 elst)))))
)
)
)
)
;; RevRefGeom (gile)
;; RefGeom inverse function
(defun RevRefGeom (ename / entData ang norm mat)
(setqentData(entget ename)
ang(- (cdr (assoc 50 entData)))
norm(cdr (assoc 210 entData))
)
(list
(setq mat
(mxm
(list (list (/ 1 (cdr (assoc 41 entData))) 0.0 0.0)
(list 0.0 (/ 1 (cdr (assoc 42 entData))) 0.0)
(list 0.0 0.0 (/ 1 (cdr (assoc 43 entData))))
)
(mxm
(list (list (cos ang) (- (sin ang)) 0.0)
(list (sin ang) (cos ang) 0.0)
'(0.0 0.0 1.0)
)
(mapcar (function (lambda (v) (trans v norm 0 T)))
'((1.0 0.0 0.0) (0.0 1.0 0.0) (0.0 0.0 1.0))
)
)
)
)
(mapcar '-
(cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 entData)))))
(mxv mat (trans (cdr (assoc 10 entData)) norm 0))
)
)
)
Gu_xl 发表于 2011-10-21 00:04
版主，可以在这个程序增加一个复制的功能吗？
Gu_xl 发表于 2011-10-21 00:04
版主这个源码可以共享一下吗？