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

明经CAD社区

 找回密码
 注册

QQ登录

只需一步，快速开始

搜索
明经CAD社区»社区 › 开发篇 › AutoLISP/Visual LISP 编程技术 › 【飞鸟集】心随我动--为LISP定制的动态输入,拖拉和动态 ...
12345678910... 20下一页
返回列表 发新帖
楼主: highflybir

[【高飞鸟】] 【飞鸟集】心随我动--为LISP定制的动态输入,拖拉和动态信息函数(更新至20130731)

    [复制链接]
liu_kunlun
发表于 2011-11-18 21:30 | 显示全部楼层
佩服，真是厉害！
回复 支持 反对

使用道具 举报

jslxt
发表于 2011-11-19 09:44 | 显示全部楼层
我会顶到你肾疼
回复 支持 反对

使用道具 举报

quarx
发表于 2011-11-19 10:20 | 显示全部楼层
华丽的命令啊
回复 支持 反对

使用道具 举报

Gu_xl
发表于 2011-11-19 10:58 | 显示全部楼层
本帖最后由 Gu_xl 于 2013-5-20 22:54 编辑

动态信息查询,由一个经典的yad动态信息查询函数改编而来!
  1. ;;;飞鸟集]心随我动--为LISP定制的动态输入，动态拖拉和动态信息函数之应用---动态信息查询
  2. ;;;由一个经典的yad动态信息查询函数改编而来！改编： Gu_xl 2011.11.19
  3. (defun InfoCallBak (PT /  TOANG    DIS ENT)
  4.   (defun toang(ang i)
  5.     (if (= i 1)
  6.       (* ang (/ 180 pi))
  7.       (* ang (/ pi 180))
  8.     )
  9.   )
  10. (defun gxl-dxf (ent i)
  11. (cdr (assoc i (entget ent)))
  12. )
  13.   (defun dis (ENT / MJBL OBJ LAYNM NAME LST)
  14.     (if (= mjdw 1000) (setq mjbl 1000000) (setq mjbl 1))
  15.     (setq obj (vlax-ename->vla-object ent))
  16.     (setq laynm (strcat "图层:" (gxl-dxf ent 8)) name (gxl-dxf ent 0))
  17.     (cond
  18.       ((= name "3DFACE")
  19.         (setq lst (list "【三维面】" laynm))
  20.       )
  21.       ((= name "3DSOLID")
  22.         (setq lst (list "【三维实体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
  23.       )
  24.       ((= name "ACAD_PROXY_ENTITY")
  25.         (setq lst (list "【代理】" laynm))
  26.       )
  27.       ((= name "ARC")
  28.         (setq lst (list "【圆弧】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
  29.                                          (strcat "圆心角:" (rtos (toang (vla-get-TotalAngle obj) 1) 2 1) "度")
  30.                                          (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
  31.                                          (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
  32.                                          (strcat "总弧长:" (rtos (vla-get-ArcLength obj) 2 0))
  33.                                          (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
  34.         ))
  35.       )
  36.       ((= name "ATTDEF")
  37.         (setq lst (list "【属性定义】" laynm (strcat "标签:" (vla-get-TagString obj))
  38.                                              (strcat "提示:" (vla-get-PromptString obj))
  39.                                              (strcat "缺省值:" (vla-get-TextString obj))
  40.                                              (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
  41.                                              (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
  42.                                              (strcat "文字样式:" (vla-get-StyleName obj))
  43.         ))
  44.       )
  45.       ((= name "ATTRIB")
  46.         (setq lst (list "【属性】" laynm (strcat "标签:" (vla-get-TagString obj))
  47.                                          (strcat "缺省值:" (vla-get-TextString obj))
  48.                                          (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
  49.                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
  50.                                          (strcat "文字样式:" (vla-get-StyleName obj))
  51.         ))
  52.       )
  53.       ((= name "BODY")
  54.         (setq lst (list "【体】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
  55.       )
  56.       ((= name "CIRCLE")
  57.         (setq lst (list "【圆】" laynm (strcat "半径:" (rtos (vla-get-radius obj) 2 0))
  58.                                        (strcat "周长:" (rtos (vla-get-Circumference obj) 2 0))
  59.                                        (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
  60.         ))
  61.       )
  62.       ((= name "DIMENSION")
  63.         (setq lst (list "【尺寸标注】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
  64.                                              (strcat "文字样式:" (vla-get-TextStyle obj))
  65.                                              (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
  66.                                              (strcat "替带文字:" (if (= (gxl-dxf ent 1) "") "无" (gxl-dxf ent 1)))
  67.         ))
  68.       )
  69.       ((= name "ELLIPSE")
  70.         (setq lst (list "【椭圆】" laynm (strcat "长轴半径:" (rtos (vla-get-MajorRadius obj) 2 0))
  71.                                          (strcat "短轴半径:" (rtos (vla-get-MinorRadius obj) 2 0))
  72.                                          (strcat "起始角:" (rtos (toang (vla-get-StartAngle obj) 1) 2 1) "度")
  73.                                          (strcat "终止角:" (rtos (toang (vla-get-EndAngle obj) 1) 2 1) "度")
  74.                                          (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
  75.         ))
  76.       )
  77.       ((= name "HATCH")
  78.         (setq lst (list "【图案填充】" laynm (strcat "图案名称:" (vla-get-PatternName obj))
  79.                                              (strcat "角度:" (rtos (toang (vla-get-PatternAngle obj) 1) 2 1))
  80.                                              (strcat "比例:" (rtos (vla-get-PatternScale obj) 2 0))
  81.                                              (strcat "关联:" (if (= (vla-get-AssociativeHatch obj) :vlax-false) "关闭" "打开"))
  82.                                              (strcat "填充样式:" (nth (vla-get-HatchStyle obj) '("普通" "外部" "忽略")))
  83.         ))
  84.       )
  85.       ((= name "IMAGE")
  86.         (setq lst (list "【图像】" laynm (strcat "图像大小:" (rtos (car (gxl-dxf ent 13)) 2 0) "X" (rtos (cadr (gxl-dxf ent 13)) 2 0))))
  87.       )
  88.       ((= name "INSERT")
  89.         (setq lst (list "【图块】" laynm (strcat "名称:" (gxl-dxf ent 2))
  90.                                          (strcat "X比例:" (rtos (gxl-dxf ent 41) 2 1))
  91.                                          (strcat "Y比例:" (rtos (gxl-dxf ent 42) 2 1))
  92.                                          (strcat "Z比例:" (rtos (gxl-dxf ent 43) 2 1))
  93.                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
  94.         ))
  95.       )
  96.       ((= name "LEADER")
  97.         (setq lst (list "【引线】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
  98.                                          (strcat "引线类型:" (gxl-dxf (list (cons 0 "折线") (cons 1 "样条曲线")) (gxl-dxf ent 72)))
  99.         ))
  100.       )
  101.       ((= name "LINE")
  102.         (setq lst (list "【直线】" laynm (strcat "长度:" (rtos (vla-get-length obj) 2 0))
  103.                                          (strcat "角度:" (rtos (toang (vla-get-angle obj) 1) 2 1) "度")
  104.         ))
  105.       )
  106.       ((= name "LWPOLYLINE")
  107.         (setq lst (list "【多段线】" laynm (strcat "常量宽度:" (if (gxl-dxf ent 43) (rtos (vla-get-ConstantWidth obj) 2 0) "变宽度"))
  108.                                             (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
  109.                                             (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
  110.         ))
  111.       )
  112.       ((= name "MLINE")
  113.         (setq lst (list "【多线】" laynm (strcat "多线样式:" (vla-get-StyleName obj))
  114.                                          (strcat "比例因子:" (rtos (gxl-dxf ent 40) 2 1))
  115.                                          (strcat "对齐:" (nth (gxl-dxf ent 70) '("上" "零" "下")))
  116.         ))
  117.       )
  118.       ((= name "MTEXT")
  119.         (setq lst (list "【多行文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
  120.                                              (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
  121.                                              (strcat "样式:" (vla-get-StyleName obj))
  122.         ))
  123.       )
  124.       ((or (= name "OLEFRame") (= name "OLE2FRame"))
  125.         (setq lst (list "【OLE边框】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
  126.       )
  127.       ((= name "POINT")
  128.         (setq lst (list "【点】" laynm))
  129.       )
  130.       ((= name "POLYLINE")
  131.         (setq lst (list "【三维多段线】" laynm))
  132.       )
  133.       ((= name "RAY")
  134.         (setq lst (list "【射线】" laynm))
  135.       )
  136.       ((= name "REGION")
  137.         (setq lst (list "【面域】" laynm (strcat "格式版本号:" (itoa (gxl-dxf ent 70)))))
  138.       )
  139.       ((= name "SHAPE")
  140.         (setq lst (list "【形】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
  141.                                        (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
  142.                                        (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
  143.         ))
  144.       )
  145.       ((= name "SOLID")
  146.         (setq lst (list "【实体】" laynm))
  147.       )
  148.       ((= name "SPLINE")
  149.         (setq lst (list "【样条曲线】" laynm (strcat "多段线:" (if (= (vla-get-Closed obj) :vlax-false) "不闭合" "闭合"))
  150.                                              (strcat "阶数:" (rtos (vla-get-Degree obj) 2 0))
  151.                                              (strcat "面积:" (rtos (/ (vla-get-Area obj) mjbl) 2 2) "㎡")
  152.         ))
  153.       )
  154.       ((= name "TEXT")
  155.         (setq lst (list "【文字】" laynm (strcat "高度:" (rtos (vla-get-Height obj) 2 0))
  156.                                          (strcat "宽度系数:" (rtos (vla-get-ScaleFactor obj) 2 1))
  157.                                          (strcat "角度:" (rtos (toang (vla-get-Rotation obj) 1) 2 1) "度")
  158.                                          (strcat "样式:" (vla-get-StyleName obj))
  159.                                          (strcat "对齐:" (nth (vla-get-Alignment obj) '("Left" "Center" "Right" "Aligned" "Middle" "Fit" "TopLeft" "TopCenter" "TopRight"
  160.                                                                                         "MiddleLeft" "MiddleCenter" "MiddleRight" "BottomLeft" "BottomCenter" "BottomRight")))
  161.         ))
  162.       )
  163.       ((= name "TOLERANCE")
  164.         (setq lst (list "【公差】" laynm (strcat "标注样式:" (vla-get-StyleName obj))
  165.                                          (strcat "文字样式:" (vla-get-TextStyle obj))
  166.                                          (strcat "文字高度:" (rtos (vla-get-TextHeight obj) 2 1))
  167.         ))
  168.       )
  169.       ((= name "TRACE")
  170.         (setq lst (list "【宽线】" laynm))
  171.       )
  172.       ((= name "VERTEX")
  173.         (setq lst (list "【顶点】" laynm (strcat "起始宽度:" (rtos (gxl-dxf ent 40) 2 0))
  174.                                          (strcat "结束宽度:" (rtos (gxl-dxf ent 41) 2 0))
  175.                                          (strcat "凸度:" (rtos (gxl-dxf ent 42) 2 1))
  176.         ))
  177.       )
  178.       ((= name "XLINE")
  179.         (setq lst (list "【构造线】" laynm))
  180.       )
  181.       (T
  182.         (setq lst (list "【未知对象】" laynm))
  183.       )
  184.     )
  185.     (apply 'strcat (mapcar '(lambda (x)(strcat x "\n")) lst))
  186.   )
  187. (if (setq ent (nentselp pt)
  188.             ent (if (and ent (= (type (last (last ent))) 'ename))
  189.                   (last (last ent))
  190.                   (car ent)
  191.                 )
  192.       )
  193. (dis ent)
  194.    )
  195. )
  196. (defun c:DynInfo  (/ loaded openview closeview)
  197.   (defun openview  (/ arxs)
  198.     (VL-ACAD-DEFUN 'InfoCallBak)
  199.     (if (null mjdw)
  200.       (progn
  201. (INITget 7 "Yes No  ")
  202. (setq Mjdw (getKword "\n以毫米为单位?[<Yes/No>]<No>:"))
  203. (if (= mjdw "Yes")
  204.    (setq mjdw 1000)
  205.    (setq mjdw 999)
  206. )
  207.       )
  208.     )
  209.     (HFB_PointMonitor)
  210.     (HFB_PointMonitor "InfoCallBak")
  211.     (princ "\n动态信息查看打开！")
  212.     (setq *dynViewEnt* t)
  213.     )
  214.   (defun closeview  ()
  215.     (HFB_PointMonitor)
  216.     (princ "\n动态信息查看关闭！")
  217.     (setq *dynViewEnt* nil)
  218.     )
  219.   (cond ((= 16 (atoi (getvar 'acadver)))
  220.   (if (not (member "dynarxfor2004-2006.arx" (arx)))
  221.     (if (setq fn (findfile "dynarxfor2004-2006.arx"))
  222.       (setq loaded (arxload fn "1"))
  223.       (setq loaded "2")
  224.       )
  225.     (setq loaded "3") ;_ 已加载
  226.     )
  227.   )
  228. ((= 17 (atoi (getvar 'acadver)))
  229.   (if (not (member "dynarxfor2007-2009.arx" (arx)))
  230.     (if (setq fn (findfile "dynarxfor2007-2009.arx"))
  231.       (setq loaded (arxload fn "1"))
  232.       (setq loaded "2")
  233.       )
  234.     (setq loaded "3")
  235.     )
  236.   )
  237. ((= 18 (atoi (getvar 'acadver)))
  238.   (if (= "x86" (getenv "PROCESSOR_ARCHITECTURE"))
  239.     (if (not (member "dynarxfor2010-2012x32.arx" (arx)))
  240.       (if (setq fn (findfile "dynarxfor2010-2012x32.arx"))
  241.         (setq loaded (arxload fn "1"))
  242.         (setq loaded "2")
  243.         )
  244.       (setq loaded "3")
  245.       )
  246.     (if (not (member "dynarxfor2010-2012x64.arx" (arx)))
  247.       (if (setq fn (findfile "dynarxfor2010-2012x64.arx"))
  248.         (setq loaded
  249.         (arxload (findfile "dynarxfor2010-2012x64.arx")
  250.           "1"))
  251.         (setq loaded "2")
  252.         )
  253.       (setq loaded "3")
  254.       )
  255.     )
  256.   )
  257. (t (setq loaded "2"))
  258. )
  259.   (if (not (or (= "1" loaded) (= "2" loaded)))
  260.     (if *dynViewEnt*
  261. (closeview)
  262. (openview)
  263. )
  264.     )
  265.   (princ)
  266.   )

点评

highflybir
64位的R2010要加载DynArxFor2010-2012x64，至于2008下的SSJIG不能运行，等下我查下缘故。可能是各个版本编译的时候搞混了。  发表于 2011-11-20 19:09

评分

参与人数 1明经币 +1 金钱 +30 收起 理由
highflybir + 1 + 30 赞一个!

查看全部评分

回复 支持 1 反对 0

使用道具 举报

fawn_lgc
发表于 2011-11-19 10:58 | 显示全部楼层
终于找到了我最想要的程序了，热泪盈眶啊
回复 支持 反对

使用道具 举报

brainstorm
发表于 2011-11-19 11:48 | 显示全部楼层
楼主的函数能够捕获键盘输入信息么 比如是按了那个字母 这样就可以定义cad的热键了
回复 支持 反对

使用道具 举报

飞诗(fsxm)
发表于 2011-11-19 22:53 | 显示全部楼层
还是输入关键字正宗些！
“热键”啥的没必要吧~！那只是grread没办法才“热键”
回复 支持 反对

使用道具 举报

飞诗(fsxm)
发表于 2011-11-19 22:53 | 显示全部楼层
还是输入关键字正宗些！
“热键”啥的没必要吧~！那只是grread没办法才“热键”
回复 支持 反对

使用道具 举报

Jack_PC
发表于 2011-11-20 10:27 | 显示全部楼层
期待LZ五十楼的惊喜
回复 支持 反对

使用道具 举报

Jack_PC
发表于 2011-11-20 10:28 | 显示全部楼层
刚好五十楼了，奖励来了
回复 支持 反对

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-26 11:13 , Processed in 1.676402 second(s), 20 queries , Gzip On.

Powered by Discuz! X3.4

Copyright © 2001-2021, Tencent Cloud.

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