[求助]鬼魔及路过的高手们，进来看一下
这个lsp是<a title="作者资料" target="_blank" href="dispuser.asp?name=%E9%AC%BC%E9%AD%94">鬼魔</a>大侠编的，在2007下运行已没问题，请问能移植在R14下运行吗<br/>是解决已知两点和弧长，画弧的东东<br/>(defun c:aaa (/ p1 p2 s a l x xx fx flx r c c1 c2 mspace myobj)<br/>(defun N ()<br/>(setq c (- (+ a (* 0.5 pi)) (* x 0.5)))<br/>(setq cen (polar p1 c r))<br/>(setq c1 (+ c pi))<br/>(setq c2 (+ c1 x))<br/>(setq myobj (vla-addarc mspace (vlax-3d-point cen) r c1 c2))<br/>(princ)<br/>)<br/>(setq p1 (getpoint "\n请输入圆弧第一点:"))<br/>(setq p2 (getpoint p1 "\n请输入圆弧第二点:"))<br/>(setq s (getdist p1 "\n请输入弧长："))<br/>(setq a (angle p1 p2))<br/>(setq l (distance p1 p2))<br/>(vl-load-com)<br/>(setq mspace (vla-get-modelspace<br/>(vla-get-activedocument (vlax-get-acad-object))<br/>)<br/>)<br/>(if (<= s l)<br/>(progn<br/>(prompt "您所要画的圆弧并不存在！")<br/>(princ)<br/>)<br/>(progn<br/>(setq x 2)<br/>(setq fx (- (/ (sin (/ x 2)) x) (/ (* 0.5 l) s)))<br/>(setq<br/>flx (/ (- (* 0.5 x (cos (* 0.5 x))) (sin (* 0.5 x))) (* x x))<br/>)<br/>(setq xx (- x (/ fx flx)))<br/>(while (> (abs (- x xx)) 0.0000000001)<br/>(setq x xx)<br/>(setq fx (- (/ (sin (/ x 2)) x) (/ (* 0.5 l) s)))<br/>(setq flx<br/>(/ (- (* 0.5 x (cos (* 0.5 x))) (sin (* 0.5 x))) (* x x))<br/>)<br/>(setq xx (- x (/ fx flx)))<br/>)<br/>(setq r (/ s xx))<br/><br/>(initget "N S")<br/>(setq aa (getkword "\n 请输入圆弧方向[逆时针(N)/顺时针(S)]:"))<br/>(if (= aa nil)<br/>(setq aa "N")<br/>)<br/>(if (= aa "N")<br/>(N)<br/>(if (= aa "S")<br/>(progn<br/>(setq c (- (+ a (/ x 2)) (* 0.5 pi)))<br/>(setq cen (polar p1 c r))<br/>(setq c1 (- (+ c pi) x))<br/>(setq c2 (+ c pi))<br/>(setq myobj (vla-addarc mspace (vlax-3d-point cen) r c1 c2))<br/>(princ)<br/>) <br/>)<br/>)<br/>)<br/>)<br/>)<br/><br/> 这个代码中使用到了 vla 类的函数, 但 R14 英文版是不代内嵌的 vba 的, 中文版的好像有, 但解密不一定完全, 使用中可能会有意外. 如果不想再麻烦那个老兄将 vla 语句修改为普通的 lsp 语句的话, 就去找个 vba for R14 安装下 <p>此Lisp寫得很好，只可惜名稱為aaa不容易看出它的用途。我試過2004運行無礙。</p> 首先申明这个程序源于ahlzl--几何算法的版主。我在这里做了些改动，以便能适应R14及以下版本。
(prompt "\n请输入命令AAA!")
(defun c:aaa (/ P1 P2 S A L x xx Fx Dx key cen rad an1 an2 mid)
;;圆心角与弧长和弦长的函数关系
(defun func (x S)
(- (* 2 (sin (/ x 2)) S) (* L x))
)
;;上面函数的求导
(defun diff (x S)
(- (* S (cos (/ x 2))) L)
)
;;输入数据
(initget 1)
(if (and (setq P1 (getpoint "\n请输入圆弧起点:"))
(setq P2 (getpoint P1 "\n请输入圆弧端点:"))
(setq S(getdist "\n请输入弧长:"))
(setq L(distance P1 P2))
(> S L)
)
(progn
(setq A(angle P1 P2))
(setq x(* 2 Pi))
(setq Fx (func x S))
(setq Dx (diff x S))
(setq xx (- x (/ Fx Dx)))
;;迭代运算
(while (> (abs (- x xx)) 1e-12)
(setq x xx)
(setq Fx (func x S))
(setq Dx (diff x S))
(setq xx (- x (/ Fx Dx)))
)
;;确定圆弧方向
(initget 0 "N S")
(setq key (getkword "\n请输入圆弧方向[逆时针(N)/顺时针(S)]<N>:"))
(if (null key)
(setq key "N")
)
(setq rad (abs (/ s xx)))
(setq mid (polar p1 A (/ l 2)))
;;准备工作
(if (= key "N")
(setq cen (polar mid (+ A (/ pi 2)) (* rad (cos (/ xx 2)))))
(setq cen (polar mid (- A (/ pi 2)) (* rad (cos (/ xx 2))))
xxp1
p1p2
p2xx
)
)
(setq an1 (angle cen p1))
(setq an2 (angle cen p2))
;;画圆弧
(entmake
(list
'(0 . "ARC")
(cons 10 cen)
(cons 40 rad)
(cons 50 an1)
(cons 51 an2)
)
)
)
(alert "输入无效或要画的圆弧不存在!")
)
(princ)
)
<p>非常抱歉，现在才看到</p><p>这程序确实不是我编的</p><p>下次我会写出处</p><p>highflybird版主确实很热心，感谢</p> 非常感谢highflybir！ <p>ahlzl與highflybir君的<font color="#ff0000"> DIFF函數</font>真漂亮，大大減少迴圈數，感謝！</p><p>在此對程式提供一點小小看法，一般畫弧採7個參數方式時，預設為逆時針方向，</p><p>所以應可以將提示方向步驟省略，由指定兩點之順序自動畫出該弧(逆時針)，</p><p>若是指定兩點之後覺得方向不對，可以在輸入弧長時，輸入負值的方式修正。</p><p></p> 利用颱風假，針對以上稍微改寫一下，提供參考:
(defun c:aaa (/ pt1 pt2 ll dd ang ang2 Fx Dx)
(setvar "cmdecho" 0)
(setq pt1 (getpoint "\n指定弧的起點: ")
pt2 (getpoint pt1 "\n指定弧的終點: ")
dd(distance pt1 pt2)
)
(setq chk 0)
(while (= chk 0)
(setq ll(getdist "\n指定弧長: "))
(if (or (null ll)(>= dd (abs ll)))
(alert "\n輸入無效或要畫的圓弧不存在，請重新設定！")
(if (> ll 0) (setq chk 1) (setq chk -1))
)
)
(setq ll (abs ll)
ang (* 2 pi)
Fx (func ang ll)
Dx (diff ang ll)
ang2 (- ang (/ Fx Dx))
)
;逼近法求角度
(while (> (abs (- ang ang2)) 1e-12)
(setq ang ang2
Fx (func ang ll)
Dx (diff ang ll)
ang2 (- ang (/ Fx Dx))
)
)
;以SEA方式畫弧，採系統預設的逆時針方向作圖
(setq ang (/ (* ang 180.0 chk) pi))
(command "arc" pt1 "e" pt2 "a" ang)
(setvar "cmdecho" 1)
(princ)
)
(prompt "\n請輸入指令 ---> AAA")
;自訂函數區
(defun func (ang ll)
(- (* 2 ll (sin (/ ang 2))) (* dd ang))
)
(defun diff (ang ll)
(- (* ll (cos (/ ang 2))) dd)
)
页:
[1]