请帮忙编一个绘制号码球的小程序。

ljcgq · 发表于 2004-2-26 18:56:00

(defun c:hm (/ p1 p2 p3 hm)
(command "line" )
(setq p1 (getpoint "起点"))
(command p1)
(setq p2(getpoint "终点") )
(command p2 "")
(setq bj (getreal "圆半径"))
(setq p3 (polar p2 (angle p1 p2) bj) )
(command "circle" p3 bj)
(setq hm(getstring "\n请输入零件号:"))
(command "text" "j" "mc" p3 (* bj 0.8) 0 hm "")
)

meflying · 发表于 2004-2-26 19:25:00

(defun GetVal(fun msg key flag vla_tmp / val)
(defun GetType(var / rVal)
(cond
((= (type var) 'STR) (setq rVal var))
((= (type var) 'INT) (setq rVal (rtos var)))
((= (type var) 'REAL) (setq rVal (rtos var)))
((= (type var) 'LIST) (setq rVal (vl-princ-to-string var)))
)
rVal
)
(if (or (not (eval vla_tmp)) (= (eval vla_tmp) ""))
(progn
(initget key (if flag flag ""))
(setq val (fun (strcat "\n" msg ":")))
)
(progn
(initget key (if flag (1- flag) ""))
(setq val (fun (strcat "\n" msg "<" (gettype (eval vla_tmp)) ">:")))
(if (or (not val) (= val "")) (setq val (eval vla_tmp)))
)
)
(set vla_tmp val)
)(defun MakeLine(pt1 pt2 / TextDxf)
(setq TextDxf '((0 . "LINE")
(100 . "AcDbEntity")
(67 . 0) (410 . "Model")
(100 . "AcDbLine")
)
)
(setq TextDxf (append TextDxf (list
(cons 10 pt1)
(cons 11 pt2)
;(cons 62 color)
'(210 0.0 0.0 1.0)
)
)
)
(entmake TextDxf)
(princ)
)(defun MakeCircle(pt R / ptInsert TextDxf)
(setq TextDxf '((0 . "CIRCLE") (100 . "AcDbEntity")
(67 . 0) (410 . "Model") (8 . "标注")
(100 . "AcDbCircle")
)
)
(setq TextDxf (append TextDxf (list
(cons 10 pt)
(cons 40 R)
'(210 0.0 0.0 1.0)
)
)
)
(entmake TextDxf)
(princ)
)(defun MakeText(pt1 str textheight / TextDxf)
(setq TextDxf '(
(0 . "TEXT")
(100 . "AcDbEntity") ; 需要所有 R12 之后版本的图元
(100 . "AcDbText") ; 将图元标记为 MTEXT
)
)
(setq TextDxf (append TextDxf (list
(cons 10 pt1)
(cons 1 str)
(cons 40 textheight)
;(cons 7 "HZ")
)
)
)
(entmake TextDxf)
(princ)
)(defun c:draw( / pt pt2 ent_lines ent_circles ptl2 pt_lst)
(setq pt (getpoint "\n输入起点:"))
(if (not TextSize)
(setq TextSize (getvar "textsize"))
)
(makeline pt (polar pt 0 1))
(setq ent_lines (entget (entlast)))
(makecircle pt textsize)
(setq ent_Circles (entget (entlast)))
(prompt "\n选择球位置")
(while (= (car (setq pt2 (grread 2 4))) 5)
(setq pt2 (cadr pt2))
(setq ptl2 (polar pt2 (angle pt2 pt) textsize))
(setq ent_lines (subst (cons 11 ptl2) (assoc 11 ent_lines) ent_lines))
(entmod ent_lines)
(setq ent_circles (subst (cons 10 pt2) (assoc 10 ent_circles) ent_circles))
(entmod ent_circles)
)
(GetVal getreal "输入球大小" "" 7 'TextSize)
(GetVal getstring "输入文字" "" 0 'Textstring)
(cond
((= (car pt2) 3)
(setq pt2 (cadr pt2))
(setq ptl2 (polar pt2 (angle pt2 pt) textsize))
(setq ent_lines (subst (cons 11 ptl2) (assoc 11 ent_lines) ent_lines))
(entmod ent_lines)
(setq ent_circles (subst (cons 10 pt2) (assoc 10 ent_circles) ent_circles))
(setq ent_circles (subst (cons 40 textsize) (assoc 40 ent_circles) ent_circles))
(entmod ent_circles)
(setq pt_lst (textbox (list '(0 . "TEXT") (cons 1 textstring) (cons 40 textsize))))
(if (/= textstring "")
(maketext
(list (- (car pt2) (/ (- (caadr pt_lst) (caar pt_lst)) 2.0)) (- (cadr pt2) (/ (- (cadadr pt_lst) (cadar pt_lst)) 2.0)))
;(polar pt2 (angle (cadr pt_lst) (car pt_lst)) (distance (car pt_lst) (cadr pt_lst)))
textstring
textsize)
)
)
)
(princ)
)

(defun GetVal(fun msg key flag vla_tmp / val)
   (defun GetType(var / rVal)
       (cond
           ((= (type var) 'STR) (setq rVal var))
           ((= (type var) 'INT) (setq rVal (rtos var)))
           ((= (type var) 'REAL) (setq rVal (rtos var)))
           ((= (type var) 'LIST) (setq rVal (vl-princ-to-string var)))
       )
       rVal
   )
   (if (or (not (eval vla_tmp)) (= (eval vla_tmp) ""))
       (progn
           (initget key (if flag flag ""))
           (setq val (fun (strcat "\n" msg ":")))
       )
       (progn
           (initget key (if flag (1- flag) ""))
           (setq val (fun (strcat "\n" msg "<" (gettype (eval vla_tmp)) ">:")))
           (if (or (not val) (= val "")) (setq val (eval vla_tmp)))
       )
   )
   (set vla_tmp val)
)(defun MakeLine(pt1 pt2 / TextDxf)
   (setq TextDxf '((0 . "LINE")
       (100 . "AcDbEntity")
       (67 . 0) (410 . "Model")
       (100 . "AcDbLine")
       )
   )
   (setq TextDxf (append TextDxf (list
           (cons 10 pt1)
           (cons 11 pt2)
           ;(cons 62 color)
           '(210 0.0 0.0 1.0)
        )
    )
   )
   (entmake TextDxf)
   (princ)
)(defun MakeCircle(pt R / ptInsert TextDxf)
   (setq TextDxf '((0 . "CIRCLE") (100 . "AcDbEntity")
       (67 . 0) (410 . "Model") (8 . "标注")
       (100 . "AcDbCircle")
       )
   )
   (setq TextDxf (append TextDxf (list
           (cons 10 pt)
           (cons 40 R)
           '(210 0.0 0.0 1.0)
        )
    )
   )
   (entmake TextDxf)
   (princ)
)(defun MakeText(pt1 str textheight / TextDxf)
   (setq TextDxf '(
           (0 . "TEXT")
           (100 . "AcDbEntity")           ; 需要所有 R12 之后版本的图元
           (100 . "AcDbText")    ; 将图元标记为 MTEXT
           )
   )
   (setq TextDxf (append TextDxf (list
           (cons 10 pt1)
           (cons 1 str)
           (cons 40 textheight)
           ;(cons 7   "HZ")
        )
    )
   )
   (entmake TextDxf)
   (princ)
)(defun c:draw( / pt pt2 ent_lines ent_circles ptl2 pt_lst)
   (setq pt (getpoint "\n输入起点:"))
   (if (not TextSize)
       (setq TextSize (getvar "textsize"))
   )
   (makeline pt (polar pt 0 1))
   (setq ent_lines (entget (entlast)))
   (makecircle pt textsize)
   (setq ent_Circles (entget (entlast)))
   (prompt "\n选择球位置")
   (while (= (car (setq pt2 (grread 2 4))) 5)
       (setq pt2 (cadr pt2))
       (setq ptl2 (polar pt2 (angle pt2 pt) textsize))
       (setq ent_lines (subst (cons 11 ptl2) (assoc 11 ent_lines) ent_lines))
       (entmod ent_lines)
       (setq ent_circles (subst (cons 10 pt2) (assoc 10 ent_circles) ent_circles))
       (entmod ent_circles)
   )
   (GetVal getreal "输入球大小" "" 7 'TextSize)
   (GetVal getstring "输入文字" "" 0 'Textstring)
   (cond
       ((= (car pt2) 3)
         (setq pt2 (cadr pt2))
         (setq ptl2 (polar pt2 (angle pt2 pt) textsize))
         (setq ent_lines (subst (cons 11 ptl2) (assoc 11 ent_lines) ent_lines))
         (entmod ent_lines)
         (setq ent_circles (subst (cons 10 pt2) (assoc 10 ent_circles) ent_circles))
         (setq ent_circles (subst (cons 40 textsize) (assoc 40 ent_circles) ent_circles))
         (entmod ent_circles)
         (setq pt_lst (textbox (list '(0 . "TEXT") (cons 1 textstring) (cons 40 textsize))))
         (if (/= textstring "")
             (maketext
   (list (- (car pt2) (/ (- (caadr pt_lst) (caar pt_lst)) 2.0)) (- (cadr pt2) (/ (- (cadadr pt_lst) (cadar pt_lst)) 2.0)))
   ;(polar pt2 (angle (cadr pt_lst) (car pt_lst)) (distance (car pt_lst) (cadr pt_lst)))
   textstring
   textsize)
         )
       )
   )
   (princ)
)

晓雨 · 发表于 2004-2-26 19:51:00

不要这么复杂嘛，简单一点，我一点都看不懂，注释多点嘛，

晓雨 · 发表于 2004-2-26 20:06:00

我来试一下，版主，你看一下，行吗？ (defun c:yuanqiu(/ pt1 pt2 d text) (setq pt1(getpoint"\n输入引线起点：") (setq pt2(getpoint"\n输入号码球放置点：") (setq d(getdist"\n输入号码球的直径：")
(setq text(getstring "\n请输入零件号: ") (command"line" pt1
我写不下去了，我知道问题在哪，我不知道怎么使两个我已经画好的图形剪切，我是想先画一直线，后画一圆，然后把圆里面的直线剪掉，

BDYCAD · 发表于 2004-2-26 20:27:00

(Defun c:test()
(if (= (getvar "cmdecho") 1)(setvar "cmdecho"0))
(if (/= (setq os (getvar "osmode")) 0) (setvar "osmode" 0))
(setq ap(getpoint "\n起點:")
bp(getpoint "\n球的中心點:")
cr(getdist "\n球的半徑:")
text (getstring "\n數值:")
ang (angle ap bp)
abd (distance ap bp))
(command ".line" ap (polar ap ang (- abd cr)) "")
(command ".circle" bp cr)
(command ".text" "j" "mc" bp "" "" text "")
(if (= (getvar "cmdecho") 0)(setvar "cmdecho"1))
(setvar "osmode" os)
(princ))

无痕 · 发表于 2004-2-26 21:02:00

插入块的方法效率不更高么？

meflying · 发表于 2004-2-26 21:14:00

如果程序写好了，插入块就显得麻烦了，因为好改变圆的大小，文字内容等，

to 晓雨：程序这么长是因为考虑了很多问题过程的动态显示、输入的人性化考虑、避免使用command命令（这个不是很必要）以及最后圆的大小和文字大小及位置，你可以试试楼上几位的程序和我的程序的效果就知道了。。。

scrsyan · 发表于 2004-2-27 08:39:00

F8的很好，没的说了。要是每次输入零件号时都比上次递增一位，就更好了。

meflying · 发表于 2004-2-27 11:30:00

找到相应位置，加上中间那句(if (and ....)) (GetVal getreal "输入球大小" "" 7 'TextSize)
(if (and textstring (= (type (read textstring)) 'INT)) (setq textstring (rtos (1+ (read textstring)))))
(GetVal getstring "输入文字" "" 0 'Textstring)

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

请帮忙编一个绘制号码球的小程序。

本帖子中包含更多资源