设为首页收藏本站CAD论坛CAD教程CAD下载明经币充值
切换到宽版

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 麻烦龙兄帮我改进一下这个中心线自动标注程序
返回列表 发新帖
查看: 2968|回复: 7

麻烦龙兄帮我改进一下这个中心线自动标注程序

[复制链接]
贱人
发表于 2004-12-23 21:08:00 | 显示全部楼层 |阅读模式
以下程序如果能达到这一点就完美了:当出现"请输入中心线长度:"的提示的时候,鼠标变成十字,可以任意点两点作为中心线长度就好了,原程序如下: ;|
zxx.lsp 中心点－中心线
* C:zxx
-- XYP@bsedi.com
2004.12.14
2004.12.15 增加中心线长度控制
2004.12.17, 22:08:32 增加注释，公布源码
2004.12.23 强制画线，增加回退控制
|;
;;;加载zxx.lsp，运行zxx。
(prompt "\n\r 加载中心点程序。")
;;;-------------------------------------------
;;;主程序
(defun c:zxx ()
(vl-load-com) ;将 Visual LISP 扩展功能加载到 AutoLISP
(cmdla0) ;保存用户设置
(setq ;;txt5 (ukword 1 "1 2" "\n请选择形式：1-显示/2-绘制" txt5)
;;格式化关键字输入
LL (ureal 1 "" "\n中心线长度" ll) ;格式化实型数键盘输入
txt5 "2" ;强制画线
)
(command "undo" "BE") ;回退开始
(while (setq pt1 (getpoint "\n\t选择区域内一点<退出> : "))
(command "-boundary" "a" "o" "r" "" pt1 "") ;建立面域
(progn
(setq
;;(vlax-safearray->list var) 以表的形式返回 SafeArray 中的元素
;;(vlax-variant-value var) 返回变体的值
;;(vla-get-Centroid Object) 取得面域或实体的面积或质量的中点
;;(vlax-ename->vla-object entname) 将 AutoLISP 类型的对象名转换为 VLA 对象
pt1
(vlax-safearray->list
(vlax-variant-value
(vla-get-centroid (vlax-ename->vla-object (entlast)))
)
)
)
(entdel (entlast)) ;删除面域
(if (= txt5 "1")
(progn
(grvecs (list 1 (POLAR PT1 0 ll) (POLAR PT1 PI ll)))
;在屏幕上绘出多重向量，长度用户控制
(grvecs
(list 1 (POLAR PT1 (/ PI 2) ll) (POLAR PT1 (* PI 1.5) ll))
)
)
)
(if (= txt5 "2")
(progn
(setvar "osmode" 0) ;取消捕捉
(mkla "中心线" 1) ;建层，取消此句可以随层
(command "line" (POLAR PT1 0 ll) (POLAR PT1 PI ll) "")
(command "line"
(POLAR PT1 (/ PI 2) ll)
(POLAR PT1 (* PI 1.5) ll)
""
)
(redraw) ;刷新屏幕
)
)
)
)
(command "undo" "E") ;回退结束
(cmdla1) ;恢复用户设置
)
;;;-------------------------------------------
;;;通用子程序
(defun CMDLA0 ()
(setq cmdech (getvar "CMDECHO"))
(setq oom (getvar "orthomode"))
(setq osm (getvar "osmode"))
(SETQ LA (getvar "clayer"))
(setq rmode (getvar "regenmode"))
(setq pw (getvar "plinewid"))
(setvar "regenmode" 0)
(setvar "CMDECHO" 0)
(princ)
)
(defun CMDLA1 ()
(setvar "CMDECHO" cmdech)
(setvar "orthomode" oom)
(setvar "osmode" osm)
(setvar "clayer" LA)
(setvar "regenmode" rmode)
(setvar "plinewid" pw)
(princ)
)
(defun ureal (bit kwd msg def / inp)
(if def
(setq msg (strcat "\n" msg "<" (rtos def 2) ">: ")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ": "))
)
(initget bit kwd)
(setq inp (getreal msg))
(if inp
inp
def
)
)
(defun mkla (name color)
(If (= (Tblsearch "layer" name) nil)
(Command "layer" "m" name "c" color name "")
(Command "layer" "t" name "s" name "c" color name "")
)
)
(defun ukword (bit kwd msg def / inp)
(if (and def (/= def ""))
(setq msg (strcat "\n" msg "<" def ">:")
bit (* 2 (fix (/ bit 2)))
)
(setq msg (strcat "\n" msg ":"))
)
(initget bit kwd)
(setq inp (getkword msg))
(if inp
inp
def
)
)
(DEFUN PXYP (TXT1)
(SETQ TXT1 (STRCAT "\n\r 程序命令: "
TXT1
" -- xyp@bsedi.com"
)
)
(PRINC TXT1)
(Princ)
)
(pxyp "ZXX (中心线)") ;加载时显示调用本程序的命令
(princ)
;;;-------------------------------------------
;;;END
"觉得好，就打赏"
打赏
还没有人打赏，支持一下
回复

使用道具 举报

f5612140
发表于 2004-12-23 23:13:00 | 显示全部楼层
可用getdist 输入数值或取二点得距离值
回复 支持 反对

使用道具 举报

龙龙仔
发表于 2004-12-24 08:49:00 | 显示全部楼层
贱人发表于2004-12-23 21:08:00回复：（贱人）麻烦龙兄帮我改进一下这个中心线自动标注程序 以下程序如果能达到这一点就完美了:当出现\"请输入中心线长度:\"的提示的时候,鼠标变成十字,可以任意点两点作为中心...

为甚么不直接要求原作者改进 ;;方法: ;;找出面域boundingbox,再画出十字(中心十字有长短),再用scale拖动缩放
回复 支持 反对

使用道具 举报

龙龙仔
发表于 2005-1-7 16:00:00 | 显示全部楼层
  2. ;;找出面域boundingbox,再画出十字(中心十字有长短),再用scale拖动缩放zxx.lsp 中心点－中心线
  3. * C:zxx
  4. -- XYP@bsedi.com
  5. 2004.12.14
  6. 2004.12.15 增加中心线长度控制
  7. 2004.12.17, 22:08:32 增加注释，公佈源码
  8. 2004.12.23 强制画线，增加回退控制
  9. |;
  10. ;;;载入zxx.lsp，运行zxx。
  11. (prompt "\n\r           载入中心点程式。")
  12. ;;;-------------------------------------------
  13. ;;;主程序
  14. (defun C:ZXX
  15.              (/ DX DY EN1 LL LST PT1 TXT5 UR CMDECH LA OOM OSM PW RMODE)
  16.    (vl-load-com)        ;将 Visual LISP 扩展功能载入到 AutoLISP
  17.    (CMDLA0)        ;保存用户设置
  18.    (setq  ;;txt5 (ukword 1 "1 2" "\n请选择形式：1-显示/2-绘製" txt5)
  19.   ;;格式化关键字输入
  20.   ;;LL     (UREAL 1 "" "\n中心线长度" LL) ;格式化实型数键盘输入
  21.   TXT5 "2"        ;强制画线
  22.    )
  23.    (command "undo" "BE")      ;回退开始
  24.    (while (setq PT1 (getpoint "\n\t选择区域内一点<退出> : "))
  25.        (command "-boundary" "a" "o" "r" "" PT1 "") ;建立面域
  26.        (progn
  27.            (setq
  28.   ;;(vlax-safearray->list var) 以表的形式返回 SafeArray 中的元素
  29.   ;;(vlax-variant-value var) 返回变体的值
  30.   ;;(vla-get-Centroid Object) 取得面域或实体的面积或质量的中点
  31.   ;;(vlax-ename->vla-object entname) 将 AutoLISP 类型的物件名转换为 VLA 物件
  32.   PT1
  33.    (vlax-safearray->list
  34.        (vlax-variant-value
  35.            (vla-get-centroid (vlax-ename->vla-object (entlast)))
  36.        )
  37.    )
  38.            )
  39.            (vla-getboundingbox
  40.   (vlax-ename->vla-object (entlast))
  41.   'LL
  42.   'UR
  43.            )
  44.            (setq LST  (mapcar 'vlax-safearray->list (list LL UR))
  45.          DX  (* 0.01 (- (caadr LST) (caar LST)))
  46.          DY  (* 0.01 (- (cadadr LST) (cadar LST)))
  47.            )
  48.            (entdel (entlast))    ;删除面域
  49.            ;|(if (= TXT5 "1")
  50.   (progn
  51.      (grvecs (list 1 (polar PT1 0 LL) (polar PT1 pi LL)))
  52.           ;在萤幕上绘出多重向量，长度用户控制
  53.      (grvecs
  54.          (list 1 (polar PT1 (/ pi 2) LL) (polar PT1 (* pi 1.5) LL))
  55.      )
  56.   )
  57.            )|;
  58.            (if (= TXT5 "2")
  59.   (progn
  60.      (setvar "osmode" 0)    ;取消捕捉
  61.      (MKLA "中心线" 1)    ;建层，取消此句可以随层
  62.      (command "line"
  63.          (polar PT1 0 DX)
  64.          (polar PT1 pi DX)
  65.          ""
  66.      )
  67.      (setq EN1 (entlast))
  68.      (command "line"
  69.          (polar PT1 (/ pi 2) DY)
  70.          (polar PT1 (* pi 1.5) DY)
  71.          ""
  72.      )
  73.      (command "_.scale" (entlast) EN1 "" PT1 PAUSE)
  74.      (redraw)      ;刷新萤幕
  75.   )
  76.            )
  77.        )
  78.    )
  79.    (command "undo" "E")      ;回退结束
  80.    (CMDLA1)        ;恢復用户设置
  81. )
  82. ;;;-------------------------------------------
  83. ;;;通用副程式
  84. (defun CMDLA0 ()
  85.    (setq CMDECH (getvar "CMDECHO"))
  86.    (setq OOM (getvar "orthomode"))
  87.    (setq OSM (getvar "osmode"))
  88.    (setq LA (getvar "clayer"))
  89.    (setq RMODE (getvar "regenmode"))
  90.    (setq PW (getvar "plinewid"))
  91.    (setvar "regenmode" 0)
  92.    (setvar "CMDECHO" 0)
  93.    (princ)
  94. )
  95. (defun CMDLA1 ()
  96.    (setvar "CMDECHO" CMDECH)
  97.    (setvar "orthomode" OOM)
  98.    (setvar "osmode" OSM)
  99.    (setvar "clayer" LA)
  100.    (setvar "regenmode" RMODE)
  101.    (setvar "plinewid" PW)
  102.    (princ)
  103. )
  104. (defun UREAL (BIT KWD MSG DEF / INP)
  105.    (if DEF
  106.        (setq MSG (strcat "\n" MSG "<" (rtos DEF 2) ">: ")
  107.      BIT (* 2 (fix (/ BIT 2)))
  108.        )
  109.        (setq MSG (strcat "\n" MSG ": "))
  110.    )
  111.    (initget BIT KWD)
  112.    (setq INP (getreal MSG))
  113.    (if INP
  114.        INP
  115.        DEF
  116.    )
  117. )
  118. (defun MKLA (NAME COLOR)
  119.    (if (= (tblsearch "layer" NAME) NIL)
  120.        (command "layer" "m" NAME "c" COLOR NAME "")
  121.        (command "layer" "t" NAME "s" NAME "c" COLOR NAME "")
  122.    )
  123. )
  124. (defun UKWORD (BIT KWD MSG DEF / INP)
  125.    (if (and DEF (/= DEF ""))
  126.        (setq MSG (strcat "\n" MSG "<" DEF ">:")
  127.      BIT (* 2 (fix (/ BIT 2)))
  128.        )
  129.        (setq MSG (strcat "\n" MSG ":"))
  130.    )
  131.    (initget BIT KWD)
  132.    (setq INP (getkword MSG))
  133.    (if INP
  134.        INP
  135.        DEF
  136.    )
  137. )
  138. (defun PXYP (TXT1)
  139.    (setq  TXT1 (strcat "\n\r           程式命令: "
  140.              TXT1
  141.              "           -- xyp@bsedi.com"
  142.            )
  143.    )
  144.    (princ TXT1)
  145.    (princ)
  146. )
  147. (PXYP "ZXX           (中心线)")    ;载入时显示调用本程式的命令
  148. (princ)
  149. ;;;-------------------------------------------
  150. ;;;END
回复 支持 反对

使用道具 举报

贱人
 楼主| 发表于 2005-1-30 00:15:00 | 显示全部楼层
龙兄,强的,比我想的还要好用,鲜花
回复 支持 反对

使用道具 举报

贱人
 楼主| 发表于 2005-4-30 16:50:00 | 显示全部楼层
能再改一下吗，把画的中心线不要放到“中心线”层，颜色也不要自动改成红色，就放到当前层，颜色就按当前层的颜色
回复 支持 反对

使用道具 举报

无痕
发表于 2005-4-30 20:33:00 | 显示全部楼层
龙龙仔，yehh！～～～～
回复 支持 反对

使用道具 举报

xyp1964
发表于 2005-5-1 22:52:00 | 显示全部楼层
  2. (load "xyp_lib")
  3.   ;|
  4. 加载通用函数
  5. 如果已经下载xyp_lib并放到搜索路径下可以不再下载!
  6. 下载地址：http://www.xdcad.net/forum/showthread.php?s=&threadid=325268
  7. 如果已在acad.lsp中添加了(load "xyp_lib")，可以直接运行下面的程序。
  8. |;
  9. (defun c:zxx (/ pt1)
  10.    (cmdla0)
  11.    (setq LL (ureal 1 "" "\n中心线长度" ll))
  12.    (while (setq pt1 (getpoint "\n选择区域内一点<退出> : "))
  13.        (command "-boundary" "a" "o" "r" "" pt1 "")
  14.        (setq pt1 (vlax-safearray->list
  15.            (vlax-variant-value
  16.                (vla-get-centroid (vlax-ename->vla-object (entlast)))
  17.            )))
  18.        (entdel (entlast))
  19.        (setvar "osmode" 0)
  20.        (command "line" (POLAR PT1 0 ll) (POLAR PT1 PI ll) "")
  21.        (command "line"(POLAR PT1 (/ PI 2) ll)
  22.            (POLAR PT1 (* PI 1.5) ll) ""
  23.        ))
  24.    (cmdla1)
  25. )
  26. (pxyp "ZXX (中心线)")
  27. (princ)
回复 支持 反对

使用道具 举报

返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|CAD论坛|CAD教程|CAD下载|联系我们|关于明经|明经通道 ( 粤ICP备05003914号 )  
©2000-2023 明经通道 版权所有 本站代码，在未取得本站及作者授权的情况下，不得用于商业用途

GMT+8, 2024-11-17 04:55 , Processed in 0.180962 second(s), 26 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

快速回复 返回顶部 返回列表