圆曲坐标

newer · 发表于 2018-9-18 00:10:26

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

(defun c:XDTB_COORDSAtCIRC
(/ e pt cl info info1 p1 p2 cir v1 v2 pm v dis dashlength)
(xdrx_begin)
(xdrx_initget 4 "0 1")
(if (not (setq tf (getkword "\n延长线[绘制-0/不绘制-1]<0>:")))
(setq tf "0")
)
(xdrx_initget)
(if (setq e (xdrx_entsel
"\n拾取圆弧或者POLYLINE曲线段<退出>"
'((0 . "ARC,LWPOLYLINE"))
)
)
(progn
(setq pt (cadr e)
e (car e)
)
(setq cl (xdrx_object_classname e))
(cond ((= (car cl) "ARC")
(setq info (apply 'xdrx_3ptoarc
($xdlsp_points_ucs2wcs (xdrx_curve_getpoint e))
)
info (mapcar '(lambda (x)
(if (= 'LIST (type x))
(trans x 1 0)
x
)
)
info
)
info1 (mapcar '(lambda (x)
(if (= 'LIST (type x))
(trans x 1 0)
x
)
)
(apply 'xdrx_arctopoly info)
)
p1 (car info1)
p2 (last info1)
)
)
((= (car cl) "LWPOLYLINE")
(setq id ($xdob_polyline_getindexatpnt e pt))
(if (= "kArc" (xdrx_polyline_segtype e id))
(setq info (xdrx_polyline_getArcSegAt e id)
p1 (xdrx_polyline_getpointat e id)
p2 (xdrx_polyline_getpointat e (1+ id))
)
)
)
)
(setq cir (car info)
cir (cadr info)
v1 ($xdlsp_points_ucs2wcs (xdrx_getperpline e p1 t))
v2 ($xdlsp_points_ucs2wcs (xdrx_getperpline e p2 t))
pm (inters p1
(mapcar '+ p1 (trans (car v1) 0 1 t))
p2
(mapcar '+ p2 (trans (car v2) 0 1 t))
nil
)
v (mapcar '- pm cir)
dis (xdrx_p2ldist pm p1 p2)
)
(xdrx_setmark)
($xdob_coords_insert pm (/ pi 3) 5.0 2.0 3.0)
($xdob_coords_setradius (entlast) (caddr info))
($XDOB_COORDS_CROSSHAIR (entlast) 1)
(if (not (minusp (cadr v)))
($xdob_coords_mirror (entlast) 1)
)
(if (= tf "0")
(progn
(xdrx_polyline_make p1 pm p2)
(xdrx_entity_setlayer (entlast) "坐标")
($XDLSP_LoadLType "dashdotx2")
(xdrx_entity_setlinetype (entlast) "dashdotx2")
(setq dashlength (xdrx_linetype_dashlengthat "dashdotx2" 0))
(xdrx_entity_setlinetypescale
(entlast)
(/ (xdrx_getpropertyvalue (entlast) "length")
10.0
dashlength
)
)
(xdrx_entity_setcolor (entlast) 1)
(xdrx_group_make
(strcat "XDTB_COORDS_CIRC_" (xdrx_getrandstr))
(xdrx_getss)
)
)
)
)
)
(xdrx_end)
(princ)
)

(defun c:XDTB_COORDSAtCIRC 
       (/ e pt cl info info1 p1 p2 cir v1 v2 pm v dis dashlength) 
  (xdrx_begin) 
  (xdrx_initget 4 "0 1") 
  (if (not (setq tf (getkword "\n延长线[绘制-0/不绘制-1]<0>:"))) 
    (setq tf "0") 
  ) 
  (xdrx_initget) 
  (if (setq e (xdrx_entsel 
                "\n拾取圆弧或者POLYLINE曲线段<退出>" 
                '((0 . "ARC,LWPOLYLINE")) 
              ) 
      ) 
    (progn 
      (setq pt (cadr e) 
            e  (car e) 
      ) 
      (setq cl (xdrx_object_classname e)) 
      (cond ((= (car cl) "ARC") 
             (setq info         (apply        'xdrx_3ptoarc 
                                ($xdlsp_points_ucs2wcs (xdrx_curve_getpoint e)) 
                         ) 
                   info         (mapcar '(lambda (x) 
                                    (if        (= 'LIST (type x)) 
                                      (trans x 1 0) 
                                      x 
                                    ) 
                                  ) 
                                 info 
                         ) 
                   info1 (mapcar '(lambda (x) 
                                    (if        (= 'LIST (type x)) 
                                      (trans x 1 0) 
                                      x 
                                    ) 
                                  ) 
                                 (apply 'xdrx_arctopoly info) 
                         ) 
                   p1         (car info1) 
                   p2         (last info1) 
             ) 
            ) 
            ((= (car cl) "LWPOLYLINE") 
             (setq id ($xdob_polyline_getindexatpnt e pt)) 
             (if (= "kArc" (xdrx_polyline_segtype e id)) 
               (setq info (xdrx_polyline_getArcSegAt e id) 
                     p1          (xdrx_polyline_getpointat e id) 
                     p2          (xdrx_polyline_getpointat e (1+ id)) 
               ) 
             ) 
            ) 
      ) 
      (setq cir        (car info) 
            cir        (cadr info) 
            v1        ($xdlsp_points_ucs2wcs (xdrx_getperpline e p1 t)) 
            v2        ($xdlsp_points_ucs2wcs (xdrx_getperpline e p2 t)) 
            pm        (inters        p1 
                        (mapcar '+ p1 (trans (car v1) 0 1 t)) 
                        p2 
                        (mapcar '+ p2 (trans (car v2) 0 1 t)) 
                        nil 
                ) 
            v        (mapcar '- pm cir) 
            dis        (xdrx_p2ldist pm p1 p2) 
      ) 
      (xdrx_setmark) 
      ($xdob_coords_insert pm (/ pi 3) 5.0 2.0 3.0) 
      ($xdob_coords_setradius (entlast) (caddr info)) 
      ($XDOB_COORDS_CROSSHAIR (entlast) 1) 
      (if (not (minusp (cadr v))) 
        ($xdob_coords_mirror (entlast) 1) 
      ) 
      (if (= tf "0") 
        (progn 
          (xdrx_polyline_make p1 pm p2) 
          (xdrx_entity_setlayer (entlast) "坐标") 
          ($XDLSP_LoadLType "dashdotx2") 
          (xdrx_entity_setlinetype (entlast) "dashdotx2") 
          (setq dashlength (xdrx_linetype_dashlengthat "dashdotx2" 0)) 
          (xdrx_entity_setlinetypescale 
            (entlast) 
            (/ (xdrx_getpropertyvalue (entlast) "length") 
               10.0 
               dashlength 
            ) 
          ) 
          (xdrx_entity_setcolor (entlast) 1) 
          (xdrx_group_make 
            (strcat "XDTB_COORDS_CIRC_" (xdrx_getrandstr)) 
            (xdrx_getss) 
          ) 
        ) 
      ) 
    ) 
  ) 
  (xdrx_end) 
  (princ) 
)

searinon · 发表于 2018-9-18 07:20:40

佩服大神佩服的啊。

konglong604 · 发表于 2018-9-18 08:59:33

谢谢你经常分享实用的程序

xoyo88 · 发表于 2019-5-6 22:15:33

圆曲坐标使用

xoyo88 · 发表于 2019-5-6 22:20:43

圆曲坐标使用圆曲坐标使用

xoyo88 · 发表于 2019-5-6 22:26:31

圆曲坐标使用圆曲坐标使用

香远益清 · 发表于 2019-11-25 16:02:11

圆曲线测设的重要参数生成。

香远益清 · 发表于 2019-11-25 16:05:51

Application Error: 0 :- no function definition: $XDOB_POLYLINE_GETINDEXATPNTADS 请求错误

流浪孤星 · 发表于 2019-11-27 11:14:39

感谢楼主分享！

aklakl49 · 发表于 2024-1-30 16:01:07

佩服大神佩服的啊。

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

[标注] 圆曲坐标

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。