中心偏移并封口

Free-Lancer · 发表于 2014-2-21 20:22:07

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

看到API有个帖子，用Lisp写了一个同样功能的
http://bbs.xdcad.net/thread-672674-1-1.html

(defun c:tt (/ _addline dis)
(defun _addline (p1 p2)
(vlax-invoke (fy:acspace) 'Addline p1 p2)
);_ ModelSpace or PaperSpace
(fy:clearcset);_Clear CURRENT Selectionset
(if (setq
dis (getdist (strcat "\nOffset Distance< "
(vl-princ-to-string (getvar "offsetdist"))
">: "
)
)
)
(setvar "offsetdist" dis)
(setq dis (getvar "offsetdist"))
)
(fy:begin);_ startundmark
(if (and (> dis 0.)
(ssget '((0 . "arc,circle,*line,ellipse")))
)
(progn
(mapcar '(lambda (x / l1 l2 lyr)
(setq lyr (vla-get-layer x)
l1 (lisp-value (api-error 'vla-offset (list x dis) t))
l2
(lisp-value (api-error 'vla-offset (list x (- dis)) t))
)
(if (and l1
l2
(= (length l1) (length l2) 1)
(or (not (vlax-curve-isclosed x))
(not (equal (vlax-curve-getstartpoint x)
(vlax-curve-getendpoint x)
1e-3
)
)
)
)
(progn
(_addline (vlax-curve-getstartpoint (car l1))
(vlax-curve-getstartpoint (car l2))
)
(_addline (vlax-curve-getendpoint (car l1))
(vlax-curve-getendpoint (car l2))
);_Draw Line
(vla-put-layer (car l1) lyr)
(vla-put-layer (car l2) lyr)
)
)
)
(fy:cset->objs);_Convert ActiveselctinSet to List of Object
)
;;(vl-cmdf ".erase" "p" "");_earse orign curve
)
)
(fy:end)
(princ)
)
(defun api-error (func lst bool / trap)
(cond
((vl-catch-all-error-p
(setq trap (vl-catch-all-apply func lst))
)
(if bool
(princ (strcat "\nError: "
(vl-catch-all-error-message trap)
)
)
)
(setq trap nil)
)
)
trap
)

(defun c:tt (/ _addline dis) 
  (defun _addline (p1 p2) 
    (vlax-invoke (fy:acspace) 'Addline p1 p2) 
  );_ ModelSpace or PaperSpace 
  (fy:clearcset);_Clear CURRENT Selectionset 
  (if (setq 
        dis (getdist (strcat "\nOffset Distance< " 
                             (vl-princ-to-string (getvar "offsetdist")) 
                             ">: " 
                     ) 
            ) 
      ) 
    (setvar "offsetdist" dis) 
    (setq dis (getvar "offsetdist")) 
  ) 
  (fy:begin);_ startundmark 
  (if (and (> dis 0.) 
           (ssget '((0 . "arc,circle,*line,ellipse"))) 
      ) 
    (progn 
      (mapcar '(lambda (x / l1 l2 lyr) 
                 (setq lyr (vla-get-layer x) 
                       l1  (lisp-value (api-error 'vla-offset (list x dis) t)) 
                       l2 
                           (lisp-value (api-error 'vla-offset (list x (- dis)) t)) 
                 ) 
                 (if (and l1 
                          l2 
                          (= (length l1) (length l2) 1) 
                          (or (not (vlax-curve-isclosed x)) 
                              (not (equal (vlax-curve-getstartpoint x) 
                                          (vlax-curve-getendpoint x) 
                                          1e-3 
                                   ) 
                              ) 
                          ) 
                     ) 
                   (progn 
                     (_addline (vlax-curve-getstartpoint (car l1)) 
                               (vlax-curve-getstartpoint (car l2)) 
                     ) 
                     (_addline (vlax-curve-getendpoint (car l1)) 
                               (vlax-curve-getendpoint (car l2)) 
                     );_Draw Line 
                     (vla-put-layer (car l1) lyr) 
                     (vla-put-layer (car l2) lyr) 
                   ) 
                 ) 
               ) 
              (fy:cset->objs);_Convert ActiveselctinSet to List of Object 
      ) 
      ;;(vl-cmdf ".erase" "p" "");_earse orign curve 
    ) 
  ) 
  (fy:end) 
  (princ) 
) 
(defun api-error (func lst bool / trap) 
  (cond 
    ((vl-catch-all-error-p 
       (setq trap (vl-catch-all-apply func lst)) 
     ) 
     (if bool 
       (princ (strcat "\nError: " 
                      (vl-catch-all-error-message trap) 
              ) 
       ) 
     ) 
     (setq trap nil) 
    ) 
  ) 
  trap 
)

天青色 · 发表于 2014-2-21 21:23:01

用CAD2004运行时显示
命令: tt
; 错误: no function definition: FY:CLEARCSET

守仁格竹GM · 发表于 2014-2-22 15:48:53

本帖最后由守仁格竹GM 于 2014-2-22 15:50 编辑

替楼主补充一些基础函数
(defun FY:Clearcset (/ cset)
  (if (not (vl-catch-all-error-p
         (setq cset
                  (vl-catch-all-apply
                  'vla-item
                  (list
                     (vla-get-selectionsets (Fy:acDoc))
                     "CURRENT"
                  )
                  )
         )
         )
   )
(vla-delete cset)
  )
  (princ)
)
(defun fy:acapp nil
  (eval (list 'defun
      'fy:acapp
      'nil
      (vlax-get-acad-object)
)
  )
  (fy:acapp)
)
(defun Fy:acDoc nil
  (eval (list 'defun
      'FY:acdoc
      'nil
      (vla-get-activedocument (fy:acapp))
)
  )
  (fy:acdoc)
)

lucas3 · 发表于 2014-2-24 14:00:53

求 fy:begin与fly:end函数

Free-Lancer · 发表于 2014-2-25 07:23:52

lucas3 发表于 2014-2-24 14:00
求 fy:begin与fly:end函数

我的签名下有编译的 app.fas 链接，包括用到的所有函数

(defun fy:error (msg)
(if (and msg (/= msg "Function cancelled"))
(prompt (strcat "Error: " msg))
(princ)
)
(fy:end)
(princ)
)
(defun fy:begin ()
(setq olderr *error*
*error* fy:error
)
(fy:Clearcset)
(fy:startundo)
t
)
(defun fy:end ()
(fy:unsetv)
(setq *error* olderr
*sysvars* nil
)
(fy:endundo)
(princ)
)

lucas3 · 发表于 2014-2-25 08:29:25

本帖最后由 lucas3 于 2014-2-25 08:38 编辑

哇，一环扣一环啊，能否补齐这里所需的所有函数？fy:unsetv， fy:startundo，FY:ACSPACE ,Free-Lancer大师，谢谢了,即使加载了您的函数库，也提示少FY:ACSPACE函数

Free-Lancer · 发表于 2014-2-25 08:53:39

lucas3 发表于 2014-2-25 08:29
哇，一环扣一环啊，能否补齐这里所需的所有函数？fy:unsetv， fy:startundo，FY:ACSPACE ,Free-Lancer大师 ...

fy:acspace 在这
http://bbs.xdcad.net/thread-672699-1-1.html

重新编译了一个

lucas3 · 发表于 2014-2-25 11:51:43

Free-Lancer 发表于 2014-2-25 08:53
fy:acspace 在这
http://bbs.xdcad.net/thread-672699-1-1.html

Free-Lancer大师为什么要编译呢？能否共享源码？

st788796 · 发表于 2014-2-25 12:02:08

本帖最后由 st788796 于 2014-2-25 12:04 编辑

lucas3 发表于 2014-2-25 11:51
Free-Lancer大师为什么要编译呢？能否共享源码？

论坛上都有源码吧
可以自己收集

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

[教学] 中心偏移并封口

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

点评

点评

点评

点评