MAK(功能:園座標輸出)
;;;功能:園座標輸出;;;BY Spring (根據龍龍仔的程序修改的)
;;;08/12-03
(defun ai_error (errmsg)
(if errmsg
'("console break"
"Function Cancelled"
)
(princ (strcat "\nError: " errmsg))
)
(princ)
) ;_defun
;;;_______________________________________________________
(defun WRITE_LIST (r_list /)
(command "_.text" "j" "C" p1 t_high 0 "序號")
(command "_.text"
"j"
"C"
(polar p1 0 (* t_high 7))
t_high
0
"孔徑"
)
(command "_.text"
"j"
"C"
(polar p1 0 (* t_high 16))
t_high
0
"X 座標"
)
(command "_.text"
"j"
"C"
(polar p1 0 (* t_high 26))
t_high
0
"Y 座標"
)
(setq p1 (polar p1 (/ pi -2.0) (* t_high 2)))
(setq N 1)
(while (/= (setq DATA (car r_list)) nil)
(setq DATA1 (car x_list))
(setq DATA2 (car y_list))
(command "_.text"
"j"
"c"
(polar p1 0 (* t_high 7))
t_high
""
(strcat "%%C" (rtos (* (car DATA) 2.0) 2 2))
)
(command "_.text"
"j"
"c"
(polar p1 0 (* t_high 16))
t_high
""
(rtos (- (car DATA1) x_p2))
)
(command "_.text"
"j"
"c"
(polar p1 0 (* t_high 25))
t_high
""
(rtos (- (car DATA2) y_p2))
)
(command "_.text"
"j"
"C"
(polar p1 0 (* t_high 0.25))
t_high
""
(rtos N)
)
(setq p1 (polar p1 (/ pi -2.0) (* t_high 2)))
(setq r_list (cdr r_list))
(setq x_list (cdr x_list))
(setq y_list (cdr y_list))
(setq N (1+ N))
)
)
;;;_______________________________________________________
(defun WRITE_LINE (/ LL)
(setq p1 (polar p1 (/ pi 2.0) (* t_high 1.5)))
(command "_.LINE"
(polar p1 pi (* t_high 2.5))
(polar p1 0 (* t_high 30))
""
)
(command "_.CHANGE" (entlast) "" "P" "Color" "2" "")
(command "_.ARRAY"
(entlast)
""
"R"
(+ (length r_list) 2)
""
(* 2 t_high)
)
(command "_.LINE"
(polar p1 pi (* t_high 2.5))
(cdr (assoc 10 (entget (entlast))))
""
)
(command "_.CHANGE" (entlast) "" "P" "Color" "2" "")
(setq LL (entlast))
(command "_.COPY" LL "" p1 (polar p1 0 (* t_high 5.0)))
(command "_.COPY" LL "" p1 (polar p1 0 (* t_high 13.5)))
(command "_.COPY" LL "" p1 (polar p1 0 (* t_high 23)))
(command "_.COPY" LL "" p1 (polar p1 0 (* t_high 32.5)))
)
;;;_______________________________________________________
(defun c:MAK (/ t_higt_high ss count r_list x_list y_list
en ed cen cen_xcen_y tmp nou p1
)
(setvar "MODEMACRO" "***SPRING***")
(setq cm (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq old_error *error*
*error* ai_error
)
(command "_.UNDO" "group")
(command "_.UCS" "World")
(princ "\nText high <")
(setq t_hig (getvar "TEXTSIZE"))
(princ t_hig)
(setq t_high (getstring ">"))
(if (= t_high "")
(setq t_high t_hig)
(setq t_high (atoi t_high))
)
(setq p2 (getpoint "\n指定基準點<0,0>:"))
(setq p3 '(0 0))
(if (= p2 nil)
(setq p2 p3)
)
(setq x_p2 (car p2))
(setq y_p2 (nth 1 p2))
(setq ss (ssget '((0 . "CIRCLE"))))
(setq count 0)
(setq r_list nil)
(setq x_list nil)
(setq y_list nil)
(while (> (sslength ss) count)
(setq en (ssname ss count))
(setq ed (entget en))
(setq cen (cdr (assoc 10 ed)))
(setq cen_x (list (car cen)))
(setq cen_y (list (cadr cen)))
(setq tmp (cdr (assoc 40 ed)))
(setq r_list (cons (list tmp count) r_list))
(setq x_list (cons cen_x x_list))
(setq y_list (cons cen_y y_list))
(setq count (1+ count))
(setq nou (itoa count))
(command "_.text" "j" "C" cen t_high "" nou)
)
(setq x_list (reverse x_list))
(setq y_list (reverse y_list))
(setq p1 (getpoint "\ninsert point"))
(setq r_list (vl-sort r_list
(function (lambda (E1 E2)
(< (cadr E1) (cadr E2))
)
)
)
)
(WRITE_LIST r_list)
(WRITE_LINE)
(command "_.UCS" "Prev")
(command "_.UNDO" "end")
(setvar "cmdecho" cm)
(setq *error* old_error)
(princ)
)
;;;此程序現在我發現有三個缺點:
;;;1)輸入的字高小於1時,程序不能執行.
;;;2)輸入的子高為1.5時,注解出來的字高卻只有1.0.
;;;3)如果有兩個同心園,就會輸出兩個園的座標,要是能判斷如果是同心園只標
;;;一個就更好了.
;;;還有此種標注方式我基本上都用不上,上次在明經通道上看到有網友需要這
;;;個程序,用這種標注方式的網友多嗎? 我画图时都是直接在上面标注
漏說了一點,上面的程序有用到 vl-sort函數,幫助文件的說明如下:
將串列中的元素依給定的比較函數排序
(vl-sortlist comparison-function)
引數
list
任意串列。
comparison-function
比較函數。如果排序順序第一個引數在第二個之前，這可以為任意接受兩個引數並傳回 T (或任意非 nil 值) 的函數。
comparison-function 的值可以為下列格式之一：
符號 (函數名稱)
'(LAMBDA (A1 A2) ...)
(FUNCTION (LAMBDA (A1 A2) ...))
傳回值
含有 list 的元素，由 comparison-function 指定順序的串列。重覆元素可能會自串列中刪除。
範例
排序數字串列：
_$ (vl-sort '(3 2 1 3) '<)
(1 2 3) ;
請注意，結果串列只包含一個 3。
以 Y 座標排序 2D 點的串列：
_$ (vl-sort '((1 3) (2 2) (3 1))
(function (lambda (e1 e2)
(< (cadr e1) (cadr e2)) ) ) )
((3 1) (2 2) (1 3))
排序符號的串列：
_$ (vl-sort
'(a d c b a)
'(lambda (s1 s2)
(< (vl-symbol-name s1) (vl-symbol-name s2)) ) )
(A B C D) ;請注意，結果串列中只有留下一個 A
我現在不想用到這個函數,因為用了這個函數就不能在R14下用這個程序了,起初我想用 reverse 函數,可是不行.這是為甚麼呢??? ;;;功能:圆坐标输出
;;;BY Spring (根据龙龙仔的程序修改的)
;;;08/12-03
(defun AI_ERROR (ERRMSG)
(if ERRMSG
'("console break"
"Function Cancelled"
)
(princ (strcat "\nError: " ERRMSG))
)
(princ)
) ;_defun
;;;_______________________________________________________
(defun WRITE_LIST (R_LIST /)
(command "_.text" "j" "C" P1 T_HIGH 0 "序号")
(command "_.text"
"j"
"C"
(polar P1 0 (* T_HIGH 7))
T_HIGH
0
"孔径"
)
(command "_.text"
"j"
"C"
(polar P1 0 (* T_HIGH 16))
T_HIGH
0
"X 坐标"
)
(command "_.text"
"j"
"C"
(polar P1 0 (* T_HIGH 26))
T_HIGH
0
"Y 坐标"
)
(setq P1 (polar P1 (/ pi -2.0) (* T_HIGH 2)))
(setq N 1)
(while (/= (setq DATA (car R_LIST)) NIL)
(setq DATA1 (car X_LIST))
(setq DATA2 (car Y_LIST))
(command "_.text"
"j"
"c"
(polar P1 0 (* T_HIGH 7))
T_HIGH
""
(strcat "%%C" (rtos (* (car DATA) 2.0) 2 2))
)
(command "_.text"
"j"
"c"
(polar P1 0 (* T_HIGH 16))
T_HIGH
""
(rtos (- (car DATA1) X_P2))
)
(command "_.text"
"j"
"c"
(polar P1 0 (* T_HIGH 25))
T_HIGH
""
(rtos (- (car DATA2) Y_P2))
)
(command "_.text"
"j"
"C"
(polar P1 0 (* T_HIGH 0.25))
T_HIGH
""
(rtos N)
)
(setq P1 (polar P1 (/ pi -2.0) (* T_HIGH 2)))
(setq R_LIST (cdr R_LIST))
(setq X_LIST (cdr X_LIST))
(setq Y_LIST (cdr Y_LIST))
(setq N (1+ N))
)
)
;;;_______________________________________________________
(defun WRITE_LINE (/ LL)
(setq P1 (polar P1 (/ pi 2.0) (* T_HIGH 1.5)))
(command "_.LINE"
(polar P1 pi (* T_HIGH 2.5))
(polar P1 0 (* T_HIGH 30))
""
)
(command "_.CHANGE" (entlast) "" "P" "Color" "2" "")
(command "_.ARRAY"
(entlast)
""
"R"
(+ (length R_LIST) 2)
""
(* 2 T_HIGH)
)
(command "_.LINE"
(polar P1 pi (* T_HIGH 2.5))
(cdr (assoc 10 (entget (entlast))))
""
)
(command "_.CHANGE" (entlast) "" "P" "Color" "2" "")
(setq LL (entlast))
(command "_.COPY" LL "" P1 (polar P1 0 (* T_HIGH 5.0)))
(command "_.COPY" LL "" P1 (polar P1 0 (* T_HIGH 13.5)))
(command "_.COPY" LL "" P1 (polar P1 0 (* T_HIGH 23)))
(command "_.COPY" LL "" P1 (polar P1 0 (* T_HIGH 32.5)))
)
;;;_______________________________________________________
(defun C:MAK (/ T_HIG T_HIGHSS COUNT R_LISTX_LIST
Y_LISTEN ED CEN CEN_X CEN_Y TMP
NOU P1 CEN_LIST N
)
(setvar "MODEMACRO" "***SPRING***")
(setq CM (getvar "cmdecho"))
(setvar "cmdecho" 0)
(setq OLD_ERROR *ERROR*
*ERROR* AI_ERROR
)
(command "_.UNDO" "group")
(command "_.UCS" "World")
(princ "\nText high <")
(setq T_HIG (getvar "TEXTSIZE"))
(princ T_HIG)
(setq T_HIGH (getstring ">"))
(if (= T_HIGH "")
(setq T_HIGH T_HIG)
(setq T_HIGH (atof T_HIGH))
)
(setq P2 (getpoint "\n指定基准点<0,0>:"))
(setq P3 '(0 0))
(if (= P2 NIL)
(setq P2 P3)
)
(setq X_P2 (car P2))
(setq Y_P2 (nth 1 P2))
(setq SS (ssget '((0 . "CIRCLE"))))
(setq COUNT 0
N 0
)
(setq R_LIST NIL)
(setq X_LIST NIL)
(setq Y_LIST NIL)
(repeat (sslength SS)
(setq EN (ssname SS N))
(setq ED (entget EN))
(if (not (member
(setq CEN (cdr (assoc 10 ED)))
CEN_LIST
)
)
(progn
(setq CEN_LIST (append CEN_LIST (list CEN)))
(setq CEN_X (list (car CEN)))
(setq CEN_Y (list (cadr CEN)))
(setq TMP (cdr (assoc 40 ED)))
(setq R_LIST (cons (list TMP COUNT) R_LIST))
(setq X_LIST (cons CEN_X X_LIST))
(setq Y_LIST (cons CEN_Y Y_LIST))
(setq COUNT (1+ COUNT))
(setq NOU (itoa COUNT))
(command "_.text" "j" "C" CEN T_HIGH "" NOU)
)
)
(setq N (1+ N))
)
(setq X_LIST (reverse X_LIST))
(setq Y_LIST (reverse Y_LIST))
(setq P1 (getpoint "\ninsert point"))
(setq R_LIST (vl-sort R_LIST
(function (lambda (E1 E2)
(< (cadr E1) (cadr E2))
)
)
)
)
(WRITE_LIST R_LIST)
(WRITE_LINE)
(command "_.UCS" "Prev")
(command "_.UNDO" "end")
(setvar "cmdecho" CM)
(setq *ERROR* OLD_ERROR)
(princ)
)
请问2楼这个程序能否加上关联性？如圆移动了，表内的数据会自动改变吗？
本帖最后由 作者 于 2003-10-23 22:04:10 编辑有谁能够帮我做到这一点呢？
我现在很需要这个功能！如：圆的位置移动了，表内的X，Y坐标也跟着变动！
如：圆的大小变了，表内的直径也自动一起改变！
请问哪个高手能够实现其功能？也就是这个例子的关联性。需建立反应器。
万分感谢！！！！
本人是从事冷冲模具设计的。
如果可以实现且送俺一份源代码细细分享一下的话割点银子也是应该的...... 呵呵,碰到同行了
這個問題得請教高手,鷹該不容易 如果可以实现且送俺一份源代码细细分享一下的话割点银子也是应该的...... 是用LISP编的吗，怎么执行，我特需要，谢谢