ZXQ0371 发表于 2018-9-26 18:42:34

付费开发Lisp小工具

http://bbs.mjtd.com/forum.php?mod=attachment&aid=MTAxNDY0fDIwZjBjOTg4fDE1Mzc5NTgyNDd8MjI5MDQ4fDE3ODE5Nw%3D%3D&noupdate=yeshttp://bbs.mjtd.com/forum.php?mod=attachment&aid=MTAxNDY1fGZkM2Q0ODUyfDE1Mzc5NTgyNDd8MjI5MDQ4fDE3ODE5Nw%3D%3D&noupdate=yes

类似“划线标注”


ZXQ0371 发表于 2018-9-26 18:43:38

划线，以交点坐标画横向或竖向的构造线

1784290342 发表于 2018-10-26 15:11:32

OBJECTARX不行吗？lisp不太会

ssyfeng 发表于 2018-10-27 12:51:32

试试这个行不行：
(defun c:tt (/ *error* ang cmdecho en endpt line-en list-pt lst ltscale os ptlst ss ssn startpt vh)
(defun *error* ( msg )
    (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
      (progn (princ (strcat "\n错误： " msg)) (vl-cmdf "_undo" "e") (vl-cmdf "_undo" 1) (setvar "CMDECHO" CMDECHO))
    )
    (princ)
)
(defun list-pt (lst)
    (if lst
      (cons
      (list
          (car lst)
          (cadr lst)
          (caddr lst)
      )
      (list-pt (cdddr lst))
      )
    )
)
(setq cmdecho (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(vl-cmdf "_undo" "be")
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 16384)
(setq startpt (getpoint "\n第一点：")
    endpt (getpoint startpt "\n第二点：")
    line-en (entmakex
            (list '(000 . "LINE")
                '(100 . "AcDbEntity")
                '(100 . "AcDbLine")
                (cons 10 startpt)
                (cons 11 endpt)
            )
            )
)
(setvar "OSMODE" os)
(setq LtScale (getvar "LtScale"))
(vl-cmdf "LtScale" (* LtScale 0.001))
(setq ss (ssget "_f" (list startpt endpt) '((0 . "*line,CIRCLE,ELLIPSE,ARC")))
    ssn (sslength ss)
    ang (angle startpt endpt)
)
(vl-cmdf "LtScale" LtScale)
(if (or (<= (* pi 0.25) ang (* pi 0.75))
      (<= (* pi 1.25) ang (* pi 1.75))
      )
    (setq VH "h")
    (setq VH "v")
)
(while (setq en (ssname ss (setq ssn (1- ssn))))
    (setq lst(vl-catch-all-apply
                'vlax-safearray->list
                (list
                  (vlax-variant-value
                  (vla-intersectwith (vlax-ename->vla-object line-en) (vlax-ename->vla-object en) acExtendNone)
                  )
                )
            )
      ptlst (if (vl-catch-all-error-p lst)
            nil
            (list-pt lst)
            )
    )
    (cond ((= VH "v")
            (mapcar '(lambda (x) (entmake (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 x) (cons 11 '(0 1 0))))) ptlst)
          )
      ((= VH "h")
      (mapcar '(lambda (x) (entmake (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 x) (cons 11 '(1 0 0))))) ptlst)
      )
    )
)
(vl-cmdf "_erase" line-en "")
(vl-cmdf "_undo" "e")
(setvar "CMDECHO" CMDECHO)
(princ)
)

f4800 发表于 2020-10-31 10:11:27

顶楼主支持楼上的。。。。。
页: [1]
查看完整版本: 付费开发Lisp小工具