易云网络 发表于 2015-5-17 10:42:33

仿Presscad 多段线方向检查

[ 本帖最后由 易云网络 于 2015-5-17 10:49 编辑 ]\n\n[ 本帖最后由 易云网络 于 2015-5-17 10:42 编辑 ]\n\n在这里有几个月了，收集了些函数，拼凑了段效率只有Presscad40%左右的源码，
现在发出来希望有朋友用得着，
顺便希望哪位大佬能提高一下效率，

(defun C:sed()

(defun sys_var ()
    (setq e_lst (mapcar (function (lambda (n) (list 'setvar n (getvar n))))
      '("cecolor" "clayer" "LUPrec" "autosnap" "osmode" "aperture" "hpspace" "hpassoc" "mirrtext" "auprec" "luprec" "dimzin" )))
    (defun *error* (msg)(mapcar 'eval e_lst)))


(defun dxf (ent i)
    (cond ((= (type ent) 'ename)
      (cdr (assoc i (entget ent '("*"))))
      )
      ((= (type ent) 'list)
      (cdr (assoc i ent))
      )
    )
)

(defun ang2rad (ang)
    (* pi (/ ang 180.))
)

;返回多义线的各顶点By ;By 无痕
(defun get-pl-pt (e / i v lst)
    (setq i -1)
    (while (setq v (vlax-curve-getpointatparam e (setq i (1+ i))))
      (setq lst (cons v lst))
    )
    (reverse lst)
)

;;8 中点+总长度+角度画直线
(defun Plline (pt Long ang)
    (setq pl1   (polar pt (ang2rad ang) (* 0.5 long) ))
    (setq pl2   (polar pt (+ pi (ang2rad ang)) (* 0.5 long) ))
    (entmake (list (cons 0 "LINE") (cons 10 pl1) (cons 11 pl2)))
)


(defun sed-error (msg) (mapcar 'eval e_lst)
    (setq ssb (ssadd))
    (while    (entnext lastty)
      (ssadd(entnext lastty) ssb)
      (setq lastty (entnext lastty))
    )
    (command "erase" ssb "")
    (princ)
)

(defun Ptline3j (p1 p2)
    (setq ang (angle p2 p1))
    ;(entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 ang tt))))
    (entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 (+ 0.5 ang) tt))))
    (entmake (list (cons 0 "LINE") (cons 10 p2) (cons 11 (polar p2 (- ang 0.5 ) tt))))
)

(setvar "cmdecho" 0)
(command ".undo" "be")
(sys_var)

(vl-load-com)

(setq   
    *error*   sed-error
    ptctr (getvar "viewctr") ; 视口中心点
    vph   (getvar "viewsize") ; 视口高度(以画图单位计算)
    vps   (getvar "screensize") ; 视口宽度和高度(以像素为单位)
    ratio (/ (car vps) (cadr vps))
    vpw   (* ratio vph)
    ptlb(list (- (car ptctr) (/ vpw 2))(- (cadr ptctr) (/ vph 2)) ); 左下角点
    ptrt(list (+ (car ptctr) (/ vpw 2))(+ (cadr ptctr) (/ vph 2)) ); 右上角点
    tt   (* 0.012 (distance ptlb ptrt))
)

(setq ss (ssget "x" '((0 . "LWPOLYLINE"))))
;(setq ss (ssget '((0 . "*POLYLINE"))))
(setq lastty (entlast));将最后一个图元记录在lastty中
(if (/= ss nil)
    (progn
      (setq   n -1)
      (repeat (sslength ss)
      (setq ent (ssname ss (setq n (1+ n))))
      (setq cx1 (get-pl-pt ent))
      (setq p11 (car cx1))
      (repeat(1- (dxfent 90))
          (setq p1 (car cx1)
            　　p2 (cadr cx1)
            　　cx1 (cdr cx1)
          )
          (Ptline3j p1 p2)
      )
      (setq p1 (car cx1)
          　　p2 (cadr cx1))
      (if (=p2 nil)
          (progn
            (entmake    (list '(0 . "CIRCLE") (cons 10 p11) (cons 40 tt)))
            (Plline p11 (+ tt tt) 45)   
            (Plline p11 (+ tt tt) -45)   
          )      
          (Ptline3j p1 p2)))
      
      (getpoint "\n---- 方向(断点)检查(ShowDir) 按按任意鼠标键:结束：")
      
      ;sa是COPY前的选择集，sb是COPY后新生成的选择集
      
      (setq ssb (ssadd))
      (while    (entnext lastty)
      (ssadd(entnext lastty) ssb)
      (setq lastty (entnext lastty))
      )
      (command "erase" ssb "")
      (princ)
      
)))

yoyoho 发表于 2015-5-17 11:32:45

感谢 易云网络 分享程序!
页: [1]
查看完整版本: 仿Presscad 多段线方向检查