付费开发Lisp小工具

ZXQ0371

类似“划线标注”

ZXQ0371

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

1784290342

OBJECTARX不行吗？lisp不太会

ssyfeng

试试这个行不行：

2. (defun c:tt (/ *error* ang cmdecho en endpt line-en list-pt lst ltscale os ptlst ss ssn startpt vh)
   
3.   (defun *error* ( msg )
   
4.     (if (not (wcmatch (strcase msg t) "*break,*cancel*,*exit*"))
   
5.       (progn (princ (strcat "\n错误： " msg)) (vl-cmdf "_undo" "e") (vl-cmdf "_undo" 1) (setvar "CMDECHO" CMDECHO))
   
6.     )
   
7.     (princ)
   
8.   )
   
9.   (defun list-pt (lst)
   
10.     (if lst
    
11.       (cons
    
12.         (list  
    
13.           (car lst)
    
14.           (cadr lst)
    
15.           (caddr lst)
    
16.         )
    
17.         (list-pt (cdddr lst))
    
18.       )
    
19.     )
    
20.   )
    
21.   (setq cmdecho (getvar "CMDECHO"))
    
22.   (setvar "CMDECHO" 0)
    
23.   (vl-cmdf "_undo" "be")
    
24.   (setq os (getvar "OSMODE"))
    
25.   (setvar "OSMODE" 16384)
    
26.   (setq startpt (getpoint "\n第一点：")
    
27.     endpt (getpoint startpt "\n第二点：")
    
28.     line-en (entmakex
    
29.               (list '(000 . "LINE")
    
30.                 '(100 . "AcDbEntity")
    
31.                 '(100 . "AcDbLine")
    
32.                 (cons 10 startpt)
    
33.                 (cons 11 endpt)
    
34.               )
    
35.             )
    
36.   )
    
37.   (setvar "OSMODE" os)
    
38.   (setq LtScale (getvar "LtScale"))  
    
39.   (vl-cmdf "LtScale" (* LtScale 0.001))
    
40.   (setq ss (ssget "_f" (list startpt endpt) '((0 . "*line,CIRCLE,ELLIPSE,ARC")))
    
41.     ssn (sslength ss)
    
42.     ang (angle startpt endpt)
    
43.   )
    
44.   (vl-cmdf "LtScale" LtScale)
    
45.   (if (or (<= (* pi 0.25) ang (* pi 0.75))
    
46.         (<= (* pi 1.25) ang (* pi 1.75))
    
47.       )
    
48.     (setq VH "h")
    
49.     (setq VH "v")
    
50.   )
    
51.   (while (setq en (ssname ss (setq ssn (1- ssn))))
    
52.     (setq lst  (vl-catch-all-apply
    
53.                 'vlax-safearray->list
    
54.                 (list
    
55.                   (vlax-variant-value
    
56.                     (vla-intersectwith (vlax-ename->vla-object line-en) (vlax-ename->vla-object en) acExtendNone)
    
57.                   )
    
58.                 )
    
59.               )
    
60.       ptlst (if (vl-catch-all-error-p lst)
    
61.               nil
    
62.               (list-pt lst)
    
63.             )
    
64.     )
    
65.     (cond ((= VH "v")
    
66.             (mapcar '(lambda (x) (entmake (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 x) (cons 11 '(0 1 0))))) ptlst)
    
67.           )
    
68.       ((= VH "h")
    
69.         (mapcar '(lambda (x) (entmake (list '(0 . "XLINE") '(100 . "AcDbEntity") '(100 . "AcDbXline") (cons 10 x) (cons 11 '(1 0 0))))) ptlst)
    
70.       )
    
71.     )
    
72.   )
    
73.   (vl-cmdf "_erase" line-en "")
    
74.   (vl-cmdf "_undo" "e")
    
75.   (setvar "CMDECHO" CMDECHO)
    
76.   (princ)
    
77. )

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

f4800

顶楼主  支持楼上的。。。。。