高飞鸟的动态函数在2004下应用一例

masterlong · 发表于 2015-6-16 00:07:21

一直以来想达成的一个功能
今天终于实现

连续画直线时
假设已指定line1两端点P1、P2
指定第三点P3
求出P3与P1、2的垂足PT
相应修改line1、2的交点P2至PT

要求看起来很简单
因为grread不支持捕捉
做出的程序没有实际意义
也曾试过gu版的函数
gu版的函数必须预先指定osmode
局限比较大只能说勉强能用

下载了高飞鸟的arx函数以后
几经折腾终于实现了最初的预想

下面是相关的一些心得
供大家参考

1.
高飞鸟的动态函数库arx文件在2004下使用时
当dwg关闭操作时可保存
但经常出现错误提示“未处理的异常.....”
具体原因不明
为避免这个问题
我想到了按需加载用完卸载的办法

2.
以上思路实际执行的时候并不顺利
卸载好处理加载时发现麻烦
程序一运行就提示“无法重复进入lisp”
而在指定第3点的过程中函数不停报错“LISP函数求值错误”
几经测试判断问题的根源在于“不能在程序中加载arx”
解决这个问题的最终办法是
建一个辅助程序专门用来加载arx
辅助程序的最后采用vla-sendcommand调用主程序

3.
借助动态函数库很快实现了想要的功能
这时发现了很严重的一个问题
程序不接受右键响应从而导致无法实现右键退出
事实证明是我错误理解了高飞鸟的帮助文件
HFB_SSJIG函数的响应方式上是这样的
设置了空回车响应时右键返回光标的坐标
而我以为是返回状态码-4
设置了空回车不响应时右键返回的也不是-4而是""

4.
高飞鸟的函数返回的是WCS下的坐标
这是要特别注意的
别的程序我为了免去换算的麻烦
可以直接在lisp一开始设定WCS
唯独这个程序必须要考虑在UCS下运行

5.
程序在结束动态拖动状态以后
光标保持十字模式没有恢复成正常模式
程序中额外增加一句(command)解决

至此大功告成
感谢高飞鸟的动态函数库
望文中的1、2、5点小毛病
高大侠有空时能顺手除之

高大侠的动态函数链接
http://bbs.mjtd.com/thread-90447-1-1.html

程序源码

20060510412 · 发表于 2021-12-1 10:21:49

20060510412 发表于 2021-11-30 22:59
请问能否分享一下那个hfb的函数呢？

好的，多谢了

20060510412 · 发表于 2021-11-30 22:59:23

ivde 发表于 2015-6-21 08:34

请问能否分享一下那个hfb的函数呢？

20060510412 · 发表于 2021-11-30 22:57:31

好厉害的程序，楼主威武

masterlong · 发表于 2015-6-16 00:08:25

不知为何不能上传附件

;;加载/卸载动态函数的路径，请自行修改
(defun c:l()
;;(load "L·（替代line）.lsp")
(if (null (member "dynamiclisp.r16.x32.arx" (arx)))
(arxload "arx\\DynamicLisp.R16.x32.arx" "")
)
(vla-sendcommand *doc* "znline ")
(princ)
)
(defun c:znline( / p1 )
(err)
(if (setq p1 (getpoint "\n【znline】 \n指定第一点:"))
(ttl_getp2 p1)
)
(no_err)
(princ)
)

(defun ttl_getp2( p1 / p2 1_list )
(if (setq p2 (getpoint p1 "\n指定下一点:"))
(progn
(setq 1_list
(entget (entmakex (list '(0 . "LINE") (cons 10 (trans p1 1 0)) (cons 11 (trans p2 1 0)))))
)
(ttl_getp3_a p1 p2 1_list)
)
)
)

(defun ttl_getp3_a( p1 p2 1_list / p3 2_list )
(initget "Z")
(setq p3 (getpoint p2 "\n转换模式(z)/指定下一点:"))
(cond
((null p3) (entupd (cdr (assoc -1 1_list))) (setvar "cmdecho" 0)(command)(arxunload "arx\\DynamicLisp.R16.x32.arx" "") )
((= p3 "Z")
(setq 2_list
(entget (entmakex (list '(0 . "LINE") (cons 10 (trans p2 1 0)) (cons 11 (trans p2 1 0)))))
)
(ttl_getp3_b p1 p2 1_list 2_list)
)
((listp p3)
(entupd (cdr (assoc -1 1_list)))
(setq 1_list
(entget (entmakex (list '(0 . "LINE") (cons 10 (trans p2 1 0)) (cons 11 (trans p3 1 0)))))
)
(entupd (cdr (assoc -1 1_list)))
(setq p1 p2  p2 p3)
(ttl_getp3_a p1 p2 1_list)
)
)
)

(defun ttl_getp3_b( p1 p2 1_list 2_list / pt newp2 )
(setq pt (HFB_SSJIG "znline_StarCallback"
"\n【垂足模式】转换模式(z)/指定下一点:"
"Z"
(+ 1  4 8 16 128 2048 65536) ;;希望右键退出的，不能 +2 ，此时右键返回""(空字符串)
2 ;;Rubber band line
(trans p2 1 0)
)
)
(cond
((listp pt)
(setq pt (trans pt 0 1))
(setq newp2 (per_po pt p1 p2))
(setq p1 newp2  p2 pt  1_list 2_list)
(ttl_getp3_a p1 p2 1_list)
)
((= pt "Z")
(entmod (subst (cons 11 (trans p2 1 0)) (assoc 11 1_list) 1_list))
(entupd (cdr (assoc -1 1_list)))
(entdel (cdr (assoc -1 2_list)))
(ttl_getp3_a p1 p2 1_list)
)
((= pt "")
(entmod (subst (cons 11 (trans p2 1 0)) (assoc 11 1_list) 1_list))
(entupd (cdr (assoc -1 1_list)))
(entdel (cdr (assoc -1 2_list)))
(setvar "cmdecho" 0)
(command)
(arxunload "arx\\DynamicLisp.R16.x32.arx" "")
)
( T
(entmod (subst (cons 11 (trans p2 1 0)) (assoc 11 1_list) 1_list))
(entupd (cdr (assoc -1 1_list)))
(entdel (cdr (assoc -1 2_list)))
(setvar "cmdecho" 0)
(command)
(arxunload "arx\\DynamicLisp.R16.x32.arx" "")
)
)
)

(defun err()
(setq olderr *error* )
(setvar "cmdecho" 0)
(command "undo" "g")

(defun *error*(msg)
   (setq *error* olderr)
(setvar "cmdecho" 0)
(command "undo" "e")
(arxunload "arx\\DynamicLisp.R16.x32.arx" "")
   (princ)
)

(defun no_err()
   (setq *error* olderr)
(command "undo" "e")
(arxunload "arx\\DynamicLisp.R16.x32.arx" "")
(princ)
)
)

;;本程序中，HFB_SSJIG的回调函数
(defun znline_StarCallback( grpt / newp2 )
(setq newp2 (per_po (trans grpt 0 1) p1 p2))
(entmod (subst (cons 11 (trans newp2 1 0)) (assoc 11 1_list) 1_list))
(setq 2_list (subst (cons 10 (trans newp2 1 0)) (assoc 10 2_list) 2_list))
(setq 2_list (subst (cons 11 grpt) (assoc 11 2_list) 2_list))
(entmod 2_list)
)

;;一点到另两点形成直线的垂足
(defun per_po( p1 p2 p3 / ang ptemp )
(setq ang (angle p2 p3))
(setq ang (+ ang (/ PI 2)))
(setq ptemp (polar p1 ang 1000))
(inters p1 ptemp p2 p3 nil)
)

(princ)

masterlong · 发表于 2015-6-19 20:22:41

后记

前两天把程序完善了一下
然后正式开始使用
结果意外发生
只要一取点CAD就直接闪退
一番折腾后无果只好放弃
开始寻找其它解决办法

先是想到了LM的动态函数
下载研究了以后对源代码进行改造
做出了自己的程序
但是LM的代码有个问题
假如捕捉模式中含有nea、end等
因为十字光标处是两条line的端点
所以在拖动过程中会始终显示nea的捕捉标识
这还导致其它捕捉模式实际无法生效

这种情况下我又想到了gu_xl的动态函数
gu版的函数可以设定捕捉避开选择集
好吧
要我自己写是写不出来
整合两大高手代码的长处
这个还是能做到的

说干就干
忙乎了很久很久
程序终于再次调试成功
并且在两高手代码的基础上
还加上了关键字

嗯
耗费了数天的功夫
耽误了n多的工作
总算没有白辛苦
还能把代码发论坛上骗点击了
怀着愉悦的心情
开始画图了

然后
程序完全无法实际使用
无它
图纸中的图元太多了
还没等鼠标移到想要的位置
CAD已经接近假死状态
那一刻我真心连骂人的力气都没了
数天的辛苦真的是白费了

再也不碰动态了
再碰剁手

masterlong · 发表于 2015-6-19 22:28:53

刚刚想到一个变通的办法
在选p3的动态过程中关闭捕捉
在光标移到目标位置后
一次右键开启捕捉
再一次右键完成取点
就是不知道这样的操作顺不顺手
速度应该是可以接受的了
好吧下次再剁手

ivde · 发表于 2015-6-20 04:10:28

用点监视器加回调即可

ivde · 发表于 2015-6-21 08:34:04

(defun c:tt (/ p1 p2 ms lm c:callback olderr myerr)
(defun myerr (msg)
(redraw)
(hfb_pointmonitor)
(princ)
)
(defun c:callback (dynpt / sp ep v pp)
(redraw)
(setq sp (vlax-curve-getstartpoint ln)
ep (vlax-curve-getendpoint ln)
v (mapcar '- ep sp)
)
(setq pp (trans (mapcar '- dynpt sp) 0 v)
pp (polar sp (angle sp ep) (last pp))
)
(grdraw (trans dynpt 0 1) (trans pp 0 1) 1 0)
(vlax-put ln 'Endpoint pp)
)
(if (and (setq p1 (getpoint "\nStart Point: "))
(setq p2 (getpoint p1 "\nEnd Point: "))
)
(progn
(setq olderr *error*
*error* myerr
)
(hfb_pointmonitor)
(setq ms (vla-get-modelspace
(vla-get-activedocument (vlax-get-acad-object))
)
)
(setq ln (vlax-invoke ms 'Addline (trans p1 1 0) (trans p2 1 0)))
(hfb_pointmonitor "C:callback")
(while (setq p (getpoint "\nNext Point: "))
(setq ln (vlax-invoke
ms
'Addline
(vlax-curve-getendpoint ln)
(trans p 1 0)
)
)
)
(hfb_pointmonitor)
(redraw)
(setq *error* olderr)
)
)
(princ)
)

(defun c:tt (/ p1 p2 ms lm c:callback olderr myerr) 
  (defun myerr (msg) 
    (redraw) 
    (hfb_pointmonitor) 
    (princ) 
  ) 
  (defun c:callback (dynpt / sp ep v pp) 
    (redraw) 
    (setq sp (vlax-curve-getstartpoint ln) 
          ep (vlax-curve-getendpoint ln) 
          v  (mapcar '- ep sp) 
    ) 
    (setq pp (trans (mapcar '- dynpt sp) 0 v) 
          pp (polar sp (angle sp ep) (last pp)) 
    ) 
    (grdraw (trans dynpt 0 1) (trans pp 0 1) 1 0) 
    (vlax-put ln 'Endpoint pp) 
  ) 
 
  (if (and (setq p1 (getpoint "\nStart Point: ")) 
           (setq p2 (getpoint p1 "\nEnd Point: ")) 
      ) 
    (progn 
      (setq olderr  *error* 
            *error* myerr 
      ) 
      (hfb_pointmonitor) 
      (setq ms (vla-get-modelspace 
                 (vla-get-activedocument (vlax-get-acad-object)) 
               ) 
      ) 
      (setq ln (vlax-invoke ms 'Addline (trans p1 1 0) (trans p2 1 0))) 
      (hfb_pointmonitor "C:callback") 
      (while (setq p (getpoint "\nNext Point: ")) 
        (setq ln (vlax-invoke 
                   ms 
                   'Addline 
                   (vlax-curve-getendpoint ln) 
                   (trans p 1 0) 
                 ) 
        ) 
      ) 
      (hfb_pointmonitor) 
      (redraw) 
      (setq *error* olderr) 
    ) 
  ) 
  (princ) 
)

ivde · 发表于 2015-6-21 08:37:24

?????????????

masterlong · 发表于 2015-6-21 15:51:09

ivde 发表于 2015-6-21 08:34

非常感谢
在你的代码基础上
已经完成了我需要的程序

采用hfb_pointmonitor这个函数以后
CAD秒退的现象暂时也没出现

masterlong · 发表于 2015-6-21 16:30:04

本帖最后由 masterlong 于 2015-6-21 16:41 编辑

高飞鸟的动态函数库arx如果不卸载
关闭dwg时会报错
下面的程序加入了自动卸载

;|
(setq
  *acad*    (vlax-get-acad-object)
  *doc*    (vla-get-activedocument *acad*)
  *mspace* (vla-get-modelspace *doc*)
)
|;
;;加载、卸载arx的路径自行修改
(defun c:l (/ p1 p2 l vline_callback olderr myerr p oldln loop )
(if (member "dynamiclisp.r16.x32.arx" (arx))
  (progn
(defun myerr (msg)
(redraw)
(if (and oldln p2)
   (progn
   (vlax-put oldln 'Endpoint (trans p2 1 0))
   (setvar "lastpoint" p2)
   )
)
(if (member "dynamiclisp.r16.x32.arx" (arx))
   (progn
   (hfb_pointmonitor)
   (arxunload "arx\\DynamicLisp.R16.x32.arx" "")
   )
)
(princ)
)
(defun vline_callback (dynpt / sp ep v pp)
(redraw)
(setq sp (vlax-curve-getstartpoint oldln)
   ep (vlax-curve-getendpoint oldln)
   v  (mapcar '- ep sp)
)
(setq pp (trans (mapcar '- dynpt sp) 0 v)
   pp (polar sp (angle sp ep) (last pp))
)
(grdraw (trans dynpt 0 1) (trans pp 0 1) 6 1)
(grdraw (trans dynpt 0 1) p2 7 1)
(vlax-put oldln 'Endpoint pp)
)

(setq p1 (getpoint "\n【自动垂线模式】第1点 : "))
(if (null p1)
(setq p1 (getvar "lastpoint"))
)
(setvar "orthomode" 1)
(if (setq p2 (getpoint p1 "\n【自动垂线模式】第2点 : "))
(progn
   (setq olderr  *error*
   *error* myerr
   )
   (hfb_pointmonitor)
   (setq oldln (vlax-invoke *MSpace* 'Addline (trans p1 1 0) (trans p2 1 0)))
   (hfb_pointmonitor "vline_callback")
   (setq loop T)
   (while loop
   ;;可以加关键字
   ;;(initget "Z")
   ;;下面这一句，不采用(getpoint p2 ...)，而是在c:callback中grdraw橡皮线。这样的好处是，不用受到orthomode的约束
   (setq p (getpoint "\n【自动垂线模式】第3点 : "))
   (cond
   ((null p)
      (vlax-put oldln 'Endpoint (trans p2 1 0))
      (setvar "lastpoint" p2)
      (redraw)
      (hfb_pointmonitor)
      (arxunload "arx\\DynamicLisp.R16.x32.arx" "")
      (setq loop NIL)
   )
   ((listp p)
      (setq ln (vlax-invoke
         *MSpace*
         'Addline
         (vlax-curve-getendpoint oldln)
         (trans p 1 0)
         )
      )
      (setvar "lastpoint" p)
      (redraw)
      (hfb_pointmonitor)
      (arxunload "arx\\DynamicLisp.R16.x32.arx" "")
      (setq loop NIL)
   )
   ;;;;可以加关键字
   ;|
   ((= p "Z")
      (princ "【Z Z Z】")
   )
   |;
   )
   )
   (setq *error* olderr)
)
)
  )
  (progn
(arxload "arx\\DynamicLisp.R16.x32.arx" "")
(vla-sendcommand *doc* "l ")
  )
)
(princ)
)

ivde · 发表于 2015-6-21 17:28:29

做个命令监视器，退出时先行卸载

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

[源码] 高飞鸟的动态函数在2004下应用一例

评分

相关帖子

点评

点评

评分

本帖子中包含更多资源