画轴剖面

lucas3 · 发表于 2014-4-26 08:52:59

HLCAD 发表于 2014-4-26 08:47
截断线符号还有好看一点的，供参考

源码呢？望大师高风亮节

HLCAD · 发表于 2014-4-26 08:58:11

lucas3 发表于 2014-4-26 08:52
源码呢？望大师高风亮节

不好意思，商业程序中自带的。
据我所知Rkadmech软件有，你可上“明经”搜索一下，有网友上传过

danyui234 · 发表于 2014-4-28 08:42:18

对做钢结构有用

lucas3 · 发表于 2014-4-29 18:57:32

黄大，那就改改，要是4条线，那就截断成管子

totorojdm · 发表于 2014-4-29 20:10:00

很好的程序,如果能判别四条线为管子~
那程序就完美了!

lucas3 · 发表于 2014-5-2 14:48:45

长老，说好的画管子的呢？{:soso_e113:}

/db_自贡黄明儒_ · 发表于 2014-9-28 10:50:38

本帖最后由 /db_自贡黄明儒_ 于 2014-9-28 10:52 编辑

;;轴剖面
(defun C:w1 (/ CMD1 FIL OSM1 P1 P2 SS)
(defun *error* (msg)
(vl-bt)
(if *DOC*
(_EndUndo *DOC*)
)
(while (not (equal (getvar "cmdnames") "")) (command nil))
(cond (cmd1 (setvar "cmdecho" cmd1)))
(HH:ayOSMode T)
(princ "\n 出错啦!")
(princ)
)
;;(setq fil '((-4 . "<or") (-4 . "<and") (0 . "LWPOLYLINE") (90 . 2) (-4 . "and>") (0 . "*LINE,ARC") (-4 . "or>")))
(cond
((and
(setq p1 (getpoint))
(setq p2 (getpoint p1))
(setq ss (ssget "_C" p1 p2 '((0 . "*LINE,ARC"))))
)
(vl-load-com)
(or *DOC*
(setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object)))
)
(_StartUndo *DOC*)
(HH:ayOSMode nil)
(setq cmd1 (getvar "cmdecho"))
(setvar "cmdecho" 0)
(VL-CATCH-ALL-APPLY 'HH::pmDo2 (list p1 p2 ss))
(setvar "cmdecho" cmd1)
(HH:ayOSMode T)
(_EndUndo *DOC*)
(gc)
)
)
(princ)
)
(defun HH::pmDo2 (p1 p2 ss / ANG BOX DIST EP EP0 LENT1 LENT2 PTS SP SP0)
(setq pts (HH::pmDo1 p1 p2 ss))
(setq sp (car pts))
(setq Ep (cadr pts))
(setq dist (* (distance sp Ep) 0.2))
(setq ang (angle sp Ep))
(setq sp0 (polar p1 (+ ang (* pi 0.5)) dist))
(setq Ep0 (polar p2 (+ ang (* pi 0.5)) dist))
(cond ((and (setq pts (HH::pmDo1 sp0 Ep0 ss)) (equal (length pts) 2))
(HH::pmDo2P (car pts) (cadr pts))
(setq Lent1 (entlast))
)
)
(setq ang (+ ang pi))
(setq sp0 (polar p1 (+ ang (* pi 0.5)) dist))
(setq Ep0 (polar p2 (+ ang (* pi 0.5)) dist))
(cond ((and (setq pts (HH::pmDo1 sp0 Ep0 ss)) (equal (length pts) 2))
(HH::pmDo2P (cadr pts) (car pts))
(setq Lent2 (entlast))
)
)
;;(setq box (* (pixel_unit) (getvar "pickbox") 0.5))
(setq sp (osnap sp "_nea"))
(setq sp (list (ssname (ssget "_C" sp sp '((0 . "*LINE,ARC"))) 0) sp))
;;(setq sp (list (ssname (ssget "_C" (mapcar '- sp (list box box)) (mapcar '+ sp (list box box)) '((0 . "*LINE"))) 0) sp))
(cond ((and Lent1 Lent2 sp) (command "_.trim" Lent1 Lent2 "" sp "")))
(setq Ep (osnap Ep "_nea"))
(setq Ep (list (ssname (ssget "_C" Ep Ep '((0 . "*LINE,ARC"))) 0) Ep))
;;(setq Ep (list (ssname (ssget "_C" (mapcar '- Ep (list box box)) (mapcar '+ Ep (list box box)) '((0 . "*LINE"))) 0) Ep))
;;(cond ((and Lent1 Lent2 sp Ep) (command "_.trim" Lent1 Lent2 "" sp Ep "")));这个两步执行
(cond ((and Lent1 Lent2 Ep) (command "_.trim" Lent1 Lent2 "" Ep "")))
)
;;两点之间所有交点的最远两点
(defun HH::pmDo1 (p1 p2 ss / E EL N PTS)
(setq eL (EntmakeLine p1 p2))
(repeat (setq n (sslength ss))
(setq e (ssname ss (setq n (1- n))))
(setq pts (append pts (HH:TwoEntsInters e eL 0)))
)
(entdel eL)
(car (MJ:lensort pts))
)
;;两点画剖面线
(defun HH::pmDo2P1 (p1 p2 / AN DIST PT)
(setq dist (distance p1 p2))
(setq an (HH::ANGLEFORMAT (angle p1 p2) 2))
(setq an (* 180 (/ ang pi)))
(setq pt (polar p1 ang (* 0.5 dist)))
(command "_.pline" p1 "a" "d" (+ an -45) pt p2 "d" (+ an 180 45) pt "")
)
(defun HH::pmDo2P (p1 p2 / P3 X Y)
(setq p3 (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2))
(entmakeX (list
'(0 . "LWPOLYLINE")
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
'(90 . 4)
(cons 10 p1)
'(42 . 0.414214)
(cons 10 p3)
'(42 . -0.414214)
(cons 10 p2)
'(42 . -0.414214)
(cons 10 p3)
'(42 . -0.414214)
)
)
)
;;167.1 [功能] Entmake直线
(defun EntmakeLine (p1 p2)
(entmakeX (list '(0 . "LINE") (cons 10 p1) (cons 11 p2)))
)
;;13 [功能] 求点集中最远，最近点表 ;By 无痕
;:(最远两点最近两点)
;;示例(MJ:lensort (while (setq pt(getpoint)) (setq plst (cons pt plst)))))
;;(((14857.8 -599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07 0.0)))
(defun MJ:lensort (ptlst / pt d maxd mind maxl minl)
(setq minl (list (car ptlst) (cadr ptlst))
maxd 0
mind (apply 'distance minl)
)
(while (setq pt (car ptlst)
ptlst (cdr ptlst)
)
(foreach n ptlst
(setq d (distance n pt))
(cond ((< maxd d)
(setq maxd d
maxl (list n pt)
)
)
((> mind d)
(setq mind d
minl (list n pt)
)
)
)
)
)
(list maxl minl)
)
;;http://bbs.xdcad.net/thread-673425-1-1.html
;;[功能] 两对象交点列表(也可能是虚交点)
;;Flag:
;;acextendnone 0 不延伸
;;acextendthisentity 1 延伸基准对象
;;acextendotherentity 2
;;acextendboth 3
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) 0)
(defun HH:TwoEntsInters (e1 e2 Flag / OBJ1 OBJ2 PTL PTS)
(setq obj1 (vla-copy (vlax-ename->vla-object e1)))
(setq obj2 (vla-copy (vlax-ename->vla-object e2)))
(XX:LeftPick:LineZto0Ent (vlax-vla-object->ename obj1))
(XX:LeftPick:LineZto0Ent (vlax-vla-object->ename obj2))
(setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag))
(VL-CATCH-ALL-APPLY 'vla-Delete (list obj1))
(VL-CATCH-ALL-APPLY 'vla-Delete (list obj2))
(while pts
(setq ptl (cons (list (car pts) (cadr pts)) ptl))
(setq pts (cdddr pts))
)
ptl
)
;;限定角度在0~C*pi之间(弧度)
;;C=1,pi; c=0.5,pi/2; c=2,2pi
(defun HH::ANGLEFORMAT (A C)
(setq B (* pi C))
(while (< A 0)
(SETQ A (+ A B))
)
(while (>= A B)
(SETQ A (- A B))
)
(cond ((EQUAL A B 1.0e-008) (SETQ A 0.0)))
A
)
;;(setq box (pixel_unit)) (setq p (getpoint))
;;(command "_.rectang" (mapcar '- p (list box box)) (mapcar '+ p (list box box)))
(defun pixel_unit (/ x y x1 y1)
(setq y (getvar "viewsize")
x1 (car (getvar "screensize"))
y1 (cadr (getvar "screensize"))
x (* y (/ x1 y1))
)
(max (abs (/ y y1))
(abs (/ x x1))
)
)

;;轴剖面 
(defun C:w1 (/ CMD1 FIL OSM1 P1 P2 SS) 
  (defun *error* (msg) 
    (vl-bt) 
    (if        *DOC* 
      (_EndUndo *DOC*)                                           
    ) 
    (while (not (equal (getvar "cmdnames") "")) (command nil)) 
    (cond (cmd1 (setvar "cmdecho" cmd1))) 
    (HH:ayOSMode T) 
    (princ "\n 出错啦!") 
    (princ) 
  ) 
  ;;(setq fil '((-4 . "<or") (-4 . "<and") (0 . "LWPOLYLINE") (90 . 2) (-4 . "and>") (0 . "*LINE,ARC") (-4 . "or>"))) 
  (cond 
    ((and 
       (setq p1 (getpoint)) 
       (setq p2 (getpoint p1)) 
       (setq ss (ssget "_C" p1 p2 '((0 . "*LINE,ARC")))) 
     ) 
 
     (vl-load-com) 
     (or *DOC* 
         (setq *DOC* (vla-get-ActiveDocument (vlax-get-acad-object))) 
     ) 
     (_StartUndo *DOC*) 
     (HH:ayOSMode nil) 
     (setq cmd1 (getvar "cmdecho")) 
     (setvar "cmdecho" 0) 
     (VL-CATCH-ALL-APPLY 'HH::pmDo2 (list p1 p2 ss)) 
     (setvar "cmdecho" cmd1) 
     (HH:ayOSMode T) 
     (_EndUndo *DOC*) 
     (gc) 
    ) 
  ) 
  (princ) 
) 
 
(defun HH::pmDo2 (p1 p2 ss / ANG BOX DIST EP EP0 LENT1 LENT2 PTS SP SP0) 
  (setq pts (HH::pmDo1 p1 p2 ss)) 
  (setq sp (car pts)) 
  (setq Ep (cadr pts)) 
  (setq dist (* (distance sp Ep) 0.2)) 
  (setq ang (angle sp Ep)) 
  (setq sp0 (polar p1 (+ ang (* pi 0.5)) dist)) 
  (setq Ep0 (polar p2 (+ ang (* pi 0.5)) dist)) 
  (cond        ((and (setq pts (HH::pmDo1 sp0 Ep0 ss)) (equal (length pts) 2)) 
         (HH::pmDo2P (car pts) (cadr pts)) 
         (setq Lent1 (entlast)) 
        ) 
  ) 
   
  (setq ang (+ ang pi)) 
  (setq sp0 (polar p1 (+ ang (* pi 0.5)) dist)) 
  (setq Ep0 (polar p2 (+ ang (* pi 0.5)) dist)) 
  (cond        ((and (setq pts (HH::pmDo1 sp0 Ep0 ss)) (equal (length pts) 2)) 
         (HH::pmDo2P (cadr pts) (car pts)) 
         (setq Lent2 (entlast)) 
        ) 
  ) 
  ;;(setq box (* (pixel_unit) (getvar "pickbox") 0.5)) 
  (setq sp (osnap sp "_nea")) 
  (setq sp (list (ssname (ssget "_C" sp sp '((0 . "*LINE,ARC"))) 0) sp)) 
  ;;(setq sp (list (ssname (ssget "_C" (mapcar '- sp (list box box)) (mapcar '+ sp (list box box)) '((0 . "*LINE"))) 0) sp)) 
  (cond ((and Lent1 Lent2 sp) (command "_.trim" Lent1 Lent2 "" sp ""))) 
  (setq Ep (osnap Ep "_nea")) 
  (setq Ep (list (ssname (ssget "_C" Ep Ep '((0 . "*LINE,ARC"))) 0) Ep)) 
  ;;(setq Ep (list (ssname (ssget "_C" (mapcar '- Ep (list box box)) (mapcar '+ Ep (list box box)) '((0 . "*LINE"))) 0) Ep)) 
  ;;(cond ((and Lent1 Lent2 sp Ep) (command "_.trim" Lent1 Lent2 "" sp Ep "")));这个两步执行 
  (cond ((and Lent1 Lent2 Ep) (command "_.trim" Lent1 Lent2 "" Ep ""))) 
) 
;;两点之间所有交点的最远两点 
(defun HH::pmDo1 (p1 p2 ss / E EL N PTS) 
  (setq eL (EntmakeLine p1 p2)) 
  (repeat (setq n (sslength ss)) 
    (setq e (ssname ss (setq n (1- n)))) 
    (setq pts (append pts (HH:TwoEntsInters e eL 0))) 
  ) 
  (entdel eL) 
  (car (MJ:lensort pts)) 
) 
;;两点画剖面线 
(defun HH::pmDo2P1 (p1 p2 / AN DIST PT) 
  (setq dist (distance p1 p2)) 
  (setq an (HH::ANGLEFORMAT (angle p1 p2) 2)) 
  (setq an (* 180 (/ ang pi)))   
  (setq pt (polar p1 ang (* 0.5 dist))) 
  (command "_.pline" p1 "a" "d" (+ an -45) pt p2 "d" (+ an 180 45) pt "") 
) 
(defun HH::pmDo2P (p1 p2 / P3 X Y) 
  (setq p3 (mapcar '(lambda (x y) (* (+ x y) 0.5)) p1 p2)) 
  (entmakeX (list 
              '(0 . "LWPOLYLINE") 
              '(100 . "AcDbEntity") 
              '(100 . "AcDbPolyline") 
              '(90 . 4) 
              (cons 10 p1) 
              '(42 . 0.414214) 
              (cons 10 p3) 
              '(42 . -0.414214) 
              (cons 10 p2) 
              '(42 . -0.414214) 
              (cons 10 p3) 
              '(42 . -0.414214) 
            ) 
  ) 
) 
;;167.1 [功能] Entmake直线 
(defun EntmakeLine (p1 p2) 
  (entmakeX (list '(0 . "LINE") (cons 10 p1) (cons 11 p2))) 
) 
;;13 [功能] 求点集中最远，最近点表   ;By 无痕 
;:(最远两点 最近两点) 
;;示例(MJ:lensort (while (setq pt(getpoint)) (setq plst (cons pt plst))))) 
;;(((14857.8 -599.932 0.0) (26695.2 -3687.68 0.0)) ((15733.8 -3687.68 0.0) (15630.7 -3842.07 0.0))) 
(defun MJ:lensort (ptlst / pt d maxd mind maxl minl) 
  (setq        minl (list (car ptlst) (cadr ptlst)) 
        maxd 0 
        mind (apply 'distance minl) 
  ) 
  (while (setq pt    (car ptlst) 
               ptlst (cdr ptlst) 
         ) 
    (foreach n ptlst 
      (setq d (distance n pt)) 
      (cond ((< maxd d) 
             (setq maxd        d 
                   maxl        (list n pt) 
             ) 
            ) 
            ((> mind d) 
             (setq mind        d 
                   minl        (list n pt) 
             ) 
            ) 
      ) 
    ) 
  ) 
  (list maxl minl) 
) 
;;http://bbs.xdcad.net/thread-673425-1-1.html 
;;[功能] 两对象交点列表(也可能是虚交点) 
;;Flag: 
;;acextendnone 0 不延伸 
;;acextendthisentity 1 延伸基准对象 
;;acextendotherentity 2 
;;acextendboth 3 
;;示例(HH:TwoEntsInters (car(entsel)) (car(entsel)) 0) 
(defun HH:TwoEntsInters        (e1 e2 Flag / OBJ1 OBJ2 PTL PTS) 
  (setq obj1 (vla-copy (vlax-ename->vla-object e1))) 
  (setq obj2 (vla-copy (vlax-ename->vla-object e2))) 
  (XX:LeftPick:LineZto0Ent (vlax-vla-object->ename obj1)) 
  (XX:LeftPick:LineZto0Ent (vlax-vla-object->ename obj2)) 
  (setq pts (vlax-invoke obj1 'Intersectwith obj2 Flag)) 
  (VL-CATCH-ALL-APPLY 'vla-Delete (list obj1)) 
  (VL-CATCH-ALL-APPLY 'vla-Delete (list obj2)) 
  (while pts 
    (setq ptl (cons (list (car pts) (cadr pts)) ptl)) 
    (setq pts (cdddr pts)) 
  ) 
  ptl 
) 
 
;;限定角度在0~C*pi之间(弧度) 
;;C=1,pi; c=0.5,pi/2; c=2,2pi 
(defun HH::ANGLEFORMAT (A C) 
  (setq B (* pi C)) 
  (while (< A 0) 
    (SETQ A (+ A B)) 
  ) 
  (while (>= A B) 
    (SETQ A (- A B)) 
  ) 
  (cond ((EQUAL A B 1.0e-008) (SETQ A 0.0))) 
  A 
) 
;;(setq box (pixel_unit)) (setq p (getpoint)) 
;;(command "_.rectang" (mapcar '- p (list box box)) (mapcar '+ p (list box box))) 
(defun pixel_unit (/ x y x1 y1) 
  (setq        y  (getvar "viewsize") 
        x1 (car (getvar "screensize")) 
        y1 (cadr (getvar "screensize")) 
        x  (* y (/ x1 y1)) 
  ) 
  (max (abs (/ y y1)) 
       (abs (/ x x1)) 
  ) 
)

lucas3 发表于 2014-5-2 14:48
长老，说好的画管子的呢？

lucas3 · 发表于 2014-9-28 10:56:57

/db_自贡黄明儒_ 发表于 2014-9-28 10:50

黄大师的代码姗姗来迟啊，我现在用的E大的:D

账号		自动登录	找回密码
密码			立即注册

[研讨] 画轴剖面

点评

点评

点评