[求助]：圆弧端点相交的切线程序

hwdong007 · 发表于 2006-2-13 23:06:44

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

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

×

功能：分别过已知圆弧两端点作其切线，并使这两根切线相交于一点。
操作：只用鼠标点击已知圆弧两端点及其圆心就可以得出上述功能的图形。
其实，我们可以用cad里面的line ,rotate,fllet(令r=0)命令句就可以得出上述图形，但是本人一天经常做很多次这样的操作，比较繁琐。各位高手能否帮忙用lisp 编写出来啊？谢谢了。

xyp1964 · 发表于 2006-2-13 23:20:16

批量操作，以后就可以经常休息了！

[FONT=courier new](load "xyp_lib.vlx") ;版本 V.20060211(2064)
;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下)
利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序：
★1·在acad.lsp中增加(load"xyp_lib.vlx")
■2·在每个程序内增加(load"xyp_lib.vlx")
■3·在command下，输入(load"xyp_lib.vlx")
■4·在菜单.mnl中增加(load"xyp_lib.vlx")
■5·将xyp_lib.vlx文件直接拽到cad屏幕
[COLOR=red] ★通用函数下载地址：[/COLOR]
[url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url]
|;
;;;圆弧端点相交切线
(defun c:test ()
(CMDLA0)
(setvar "osmode" 0)
(setq ss (ssget '((0 . "ARC")))
i -1
)
(mkla "切线" 3)
(while (setq s1 (ssname ss (setq i (1+ i))))
(setq ps (xyp-get-CurveStartPoint s1);圆弧起点
pe (xyp-get-CurveEndPoint s1);圆弧终点
ps1 (xyp-get-QiexianAtPoint s1 ps 1000);圆弧起点处切线上点
pe1 (xyp-get-QiexianAtPoint s1 pe 1000);圆弧终点处切线上点
pt (inters ps ps1 pe pe1 nil);以上四点连线延长线之交点
)
(if pt
(progn
(command "LINE" ps pt "")
(command "LINE" pe pt "")
)
)
)
(CMDLA1)
)[/FONT]

[FONT=courier new](load "xyp_lib.vlx")                        ;版本 V.20060211(2064) 
;|下载和加载通用函数(可在签名栏直接下载后放到搜索路径下) 
利用以下任何一种方式（首选第一种）即可加载和运行通用函数内的所有子程序： 
★1·在acad.lsp中增加(load"xyp_lib.vlx") 
■2·在每个程序内增加(load"xyp_lib.vlx") 
■3·在command下，输入(load"xyp_lib.vlx") 
■4·在菜单.mnl中增加(load"xyp_lib.vlx") 
■5·将xyp_lib.vlx文件直接拽到cad屏幕 
[COLOR=red] ★通用函数下载地址：[/COLOR] 
[url]http://www.xdcad.net/forum/attachment.php?s=&postid=1606661[/url] 
|; 
 
;;;圆弧端点相交切线 
(defun c:test () 
  (CMDLA0) 
  (setvar "osmode" 0) 
  (setq        ss (ssget '((0 . "ARC"))) 
        i  -1 
  ) 
  (mkla "切线" 3) 
  (while (setq s1 (ssname ss (setq i (1+ i)))) 
    (setq ps  (xyp-get-CurveStartPoint s1);圆弧起点 
          pe  (xyp-get-CurveEndPoint s1);圆弧终点 
          ps1 (xyp-get-QiexianAtPoint s1 ps 1000);圆弧起点处切线上点 
          pe1 (xyp-get-QiexianAtPoint s1 pe 1000);圆弧终点处切线上点 
          pt  (inters ps ps1 pe pe1 nil);以上四点连线延长线之交点 
    ) 
    (if        pt 
      (progn 
        (command "LINE" ps pt "") 
        (command "LINE" pe pt "") 
      ) 
    ) 
  ) 
  (CMDLA1) 
)[/FONT]

ljpnb · 发表于 2006-2-14 12:01:45

[php]
(defun c:test ()
  (setvar "cmdecho" 0)
  (setq os (getvar "osmode"))
  (command "undo" "be")
  (setvar "osmode" 0)
  (princ "\n选择圆弧...")
  (setq ss (ssget '((0 . "ARC"))))
  (setq i 0 k 0)
  (repeat (sslength ss)
(setq obj (vlax-ename->vla-object (ssname ss i)))
(setq r       (vla-get-radius obj)
   startpoint  (vlax-safearray->list
(vlax-variant-value (vla-get-startpoint obj))
      )
   endpoint (vlax-safearray->list
(vlax-variant-value (vla-get-endpoint obj))
      )
   centerpoint (vlax-safearray->list
(vlax-variant-value (vla-get-center obj))
      )
)
(setq midpoint (mapcar '(lambda (a b) (/ (+ a b) 2))
   startpoint
   endpoint
   )
)
(if (not (equal midpoint centerpoint 0.00001))
   (progn
   (setq len (distance centerpoint midpoint)
      ang (angle centerpoint midpoint)
   )

(setq point (polar centerpoint ang (/ (* r r) len)))
(command "LINE" startpoint point endpoint "")
)
(setq k (1+ k))
)
(setq i (1+ i))
  )
  (princ (strcat "\n有" (rtos k) "个半圆形的圆弧无法完成操作!"))
  (setvar "osmode" os)
  (command "undo" "e")
  (setvar "cmdecho" 1)
  (princ)
)
[/php]

xyp1964 · 发表于 2006-2-14 12:49:06

最初由 ljpnb 发布

应避免选择集为空时的出错（属于sslength函数的bug），没有半圆时可以不出现提示，修改如下供参考：
[php]
(defun c:test ()
  (setvar "cmdecho" 0)
  (setq os (getvar "osmode")
i  0
k  0
  )
  (command "undo" "be")
  (setvar "osmode" 0)
  (princ "\n选择圆弧...")
  (if (setq ss (ssget '((0 . "ARC"))))
(repeat (sslength ss)
   (setq obj (vlax-ename->vla-object (ssname ss i))
      r (vla-get-radius obj)
      startpoint (vlax-safearray->list
   (vlax-variant-value (vla-get-startpoint obj))
)
      endpoint (vlax-safearray->list
   (vlax-variant-value (vla-get-endpoint obj))
)
      centerpoint (vlax-safearray->list
   (vlax-variant-value (vla-get-center obj))
)
      midpoint (mapcar '(lambda (a b) (/ (+ a b) 2))
startpoint
endpoint
)
   )
   (if (not (equal midpoint centerpoint 0.00001))
(progn
   (setq len (distance centerpoint midpoint)
ang (angle centerpoint midpoint)
point (polar centerpoint ang (/ (* r r) len))
   )
   (command "LINE" startpoint point endpoint "")
)
(setq k (1+ k))
   )
   (setq i (1+ i))
)
  )
  (if (> k 0)
(princ
   (strcat "\n有" (rtos k 2 0) "个半圆形的圆弧无法完成操作!")
)
  )
  (setvar "osmode" os)
  (command "undo" "e")
  (setvar "cmdecho" 1)
  (princ)
)
[/php]

ljpnb · 发表于 2006-2-14 13:17:12

多谢xyp1964 版大的指点，记下了。

puyun006 · 发表于 2006-2-15 13:21:05

我正好用的上.多谢

hwdong007 · 发表于 2006-2-17 00:06:30

加载以后出现错误: no function definition: VLAX-ENAME->VLA-OBJECT
请问如何更正？

ljpnb · 发表于 2006-2-17 07:48:52

把这句(vl-load-com)加到程序前面

hwdong007 · 发表于 2006-2-17 19:37:45

非常感谢各位的指点，还想请教一下，我是一个新手，如何学好lisp语言阿？

eachy · 发表于 2006-2-18 20:57:27

(defun c:tt (/ ss ssl e sp ep p1 p2 pt sp1 ep1)
(if (setq ss (ssget '((0 . "arc"))))
(progn
(setq ssl (sslength ss)
i -1
)
(repeat ssl
(setq e (ssname ss (setq i (1+ i)))
sp (vlax-curve-getstartpoint e)
ep (vlax-curve-getendpoint e)
p1 (vlax-curve-getfirstderiv e (vlax-curve-getstartparam e))
p2 (vlax-curve-getfirstderiv e (vlax-curve-getendparam e))
sp1 (mapcar '+ sp p1)
ep1 (mapcar '+ ep p2)
pt (inters sp sp1 ep ep1 nil)
)
(if pt
(command ".line" "_none" sp "_none" pt "_none" ep "")
)
)
)
)
(princ)
)

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

[求助] [求助]：圆弧端点相交的切线程序

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

相关帖子

浏览过的版块