求直线或者多段线定距缩短的lisp

satan421

yuping913 发表于 2019-4-15 08:48
大神能帮忙改一下吗？我初学好多地方看不明白

你说的原对象的属性是指什么，颜色、线型、图层？还是扩展数据xdata？还是什么别的

ketxu

Mine version.

2. (defun c:COL (/ s *error* l _id)
   
3. (defun *error*(m)
   
4.         (princ m)
   
5.         (:CM:EndMark *CM:Doc*)
   
6.         (if oCMD (setvar 'cmdEcho oCMD))
   
7.         ;(if l (setq *lSetting* l))
   
8.         (princ)
   
9. )
   
10. (:CM:StartMark *CM:Doc*)
    
11. (setq oCMD (getvar 'cmdecho))(setvar 'cmdecho 0)
    
12.         ;Private function
    
13. (cond
    
14. (
    
15.         (and
    
16.                 ;Select
    
17.                 (setq s
    
18.                         (:CM:SS-Select "\nCh\U+1ECDn c\U+00E1c Line, Pline, Arc, SPLINE mu\U+1ED1n thay \U+0111\U+1ED5i chi\U+1EC1u d\U+00E0i :"
    
19.                                 (list "_:L" '((0 . "LINE,LWPOLYLINE,POLYLINE,ARC,SPLINE")))                                       
    
20.                         )
    
21.                 )
    
22.                 ;Setting
    
23.                 ;Chi can doan nay la vua thiet dat che do hien hanh, vua tao dialog. Chua co phan luu key vao Reg
    
24.                 (setq *lSetting*
    
25.                         ((lambda(/ fl ret dcl_id lstKey init l)
    
26.                         (setq fl (vl-filename-mktemp "mip" nil ".dcl"))
    
27.                         (setq         ret (open fl "w")                                         
    
28.                                         tt         "Ch\U+01B0\U+01A1ng tr\U+00ECnh cho ph\U+00E9p k\U+00E9o d\U+00E0i \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Line, Polyline, LWPolyline, Arc theo ph\U+00EDa
    
29.                                                         \n\\U+00A9 Ketxu 3/2017
    
30.                                                         \nMail : ks.stung@gmail.com
    
31.                                                         \niCad Group"
    
32.                                         title "Change Objects Length v1"
    
33.                         )
    
34.                         (or *lengDelta* (setq *lengDelta* 10))
    
35.                         ;List key_label_value default
    
36.                         (or *lSetting* (setq *lSetting* '(("kStart" "\U+0110\U+1EA7u" "0")("kEnd" "Cu\U+1ED1i" "0")("kBoth" "C\U+1EA3 2 ph\U+00EDa" "1") ("kTotal" "T\U+1ED5ng" "0"))))
    
37.                         (mapcar
    
38.                         '(lambda (x) (write-line x ret))
    
39.                                 (list
    
40.                                         "Dialog : dialog { "
    
41.                                         (strcat "label="" title ""; width = 10;fixed_width = true;")
    
42.                                                 ":edit_box {label ="Chi\U+1EC1u d\U+00E0i :";key = "kDel";}"
    
43.                                                 " :radio_column{"
    
44.                                                                
    
45.                                                                 (strcat "label="" "Ph\U+00EDa :"  "";")
    
46.                                                                 (apply 'strcat (mapcar '(lambda (x)(strcat ":radio_button {key="" (car x) "";width=2;label="" (cadr x) "";}")) *lSetting*))                                
    
47.                                                                 ": spacer { height = 0.2; }"               
    
48.                                        
    
49.                                                                 " :text_part {alignment=centered;"
    
50.                                                                   (strcat "label="" "\\U+00A9 Ketxu - iCad Tools" "";")
    
51.                                                                 "}"
    
52.                                                         "}"
    
53.                                                 ": column {"
    
54.                                                 ": row {"
    
55.                                                 "    fixed_width = true;"
    
56.                                                 "    alignment = centered;"
    
57.                                                 ":button {label = "Ok";key = "kOK";is_cancel = true;fixed_width = true;width = 1;is_default = 1;}"
    
58.                                                 ":button {label = "Help";fixed_width = true;width = 1;key = "kHelp";}"               
    
59.                                                 "}"
    
60.                                                 "}}"
    
61.                                 )   
    
62.                         ) ;_ end of mapcar
    
63.                         ;Load DCL
    
64.                         (setq ret (close ret))
    
65.                         (if (and (not (minusp (setq dcl_id (load_dialog fl))))
    
66.                                    (new_dialog "Dialog" dcl_id)
    
67.                           ) ;_ end of and
    
68.                         (progn
    
69.                                 
    
70.                                 ;Init
    
71.                                 (defun init()
    
72.                                         (mapcar '(lambda(x)(set_tile (car x) (last x))) *lSetting*)
    
73.                                         (set_tile "kDel" (rtos *lengDelta*))
    
74.                                 )
    
75.                                 (init)
    
76.                                 
    
77.                                 ;Get all value when change               
    
78.                                 (defun Get_Value(/ l1)
    
79.                                 (setq *lengDelta* (distof (get_tile "kDel")))
    
80.                                 (mapcar  
    
81.                                                 '(lambda(x)(list (car x) (cadr x)(get_tile (car x))))
    
82.                                                 *lSetting*
    
83.                                 )                        
    
84.                                 )
    
85.                                 (defun        get_len()
    
86.                                                 (if (not (distof (get_tile "kDel")))(alert "Vui l\U+00F2ng nh\U+1EADp s\U+1ED1 !"))                                
    
87.                                 )
    
88.                                 (action_tile "kOK" "(setq ret (Get_value))(done_dialog 4)")
    
89.                                 (action_tile "kDel" "(get_len)")               
    
90.                                 (action_tile "kHelp" "(alert tt)")               
    
91.                                 
    
92.                           (setq dlg_Exit (start_dialog))         
    
93.                         ) ;_ end of progn
    
94.                         ) ;_ end of if
    
95.                         (unload_dialog dcl_id)  
    
96.                         (vl-file-delete fl)
    
97.                         ret
    
98.                 ))
    
99.                 );End setq
    
100.         );End And + Cond
     
101.         (defun _id(i)(= (last (assoc i *lSetting*)) "1"))
     
102.         (foreach e (:CM:SS->List s)
     
103.         (apply 'command
     
104.                 (append
     
105.                         (list "_.lengthen")
     
106.                         (cond         ((_id "kStart") (list "_delta" *lengDelta* (list e (vlax-curve-getstartpoint e)) ""))
     
107.                                         ((_id "kEnd") (list "_delta" *lengDelta* (list e (vlax-curve-getendpoint e)) ""))
     
108.                                         ((_id "kBoth") (list "_delta" *lengDelta* (list e (vlax-curve-getendpoint e)) (list e (vlax-curve-getstartpoint e)) ""))
     
109.                                         ((_id "kTotal") (list "Total" *lengDelta* (list e (vlax-curve-getstartpoint e)) ""))
     
110.                         )
     
111.                 )               
     
112.         ))
     
113. )
     
114. (T (princ "\nL\U+1ED7i ! Xin li\U+00EAn h\U+1EC7 v\U+1EDBi t\U+00E1c gi\U+1EA3 !") )
     
115. )
     
116. (*error* nil)
     
117. (princ)
     
118. )
     
119. 
     
120. <blockquote>  (vl-load-com)

(defun c:COL (/ s *error* l _id)<br /> (defun *error*(m)<br />         (princ m)<br />         (:CM:EndMark *CM:Doc*)<br />         (if oCMD (setvar 'cmdEcho oCMD))<br />         ;(if l (setq *lSetting* l))<br />         (princ)<br /> )<br /> (:CM:StartMark *CM:Doc*)<br /> (setq oCMD (getvar 'cmdecho))(setvar 'cmdecho 0)<br />         ;Private function<br /> (cond<br /> (<br />         (and<br />                 ;Select<br />                 (setq s <br />                         (:CM:SS-Select "\nCh\U+1ECDn c\U+00E1c Line, Pline, Arc, SPLINE mu\U+1ED1n thay \U+0111\U+1ED5i chi\U+1EC1u d\U+00E0i :"<br />                                 (list "_:L" '((0 . "LINE,LWPOLYLINE,POLYLINE,ARC,SPLINE")))                                        <br />                         )<br />                 )<br />                 ;Setting<br />                 ;Chi can doan nay la vua thiet dat che do hien hanh, vua tao dialog. Chua co phan luu key vao Reg <br />                 (setq *lSetting*<br />                         ((lambda(/ fl ret dcl_id lstKey init l) <br />                         (setq fl (vl-filename-mktemp "mip" nil ".dcl"))<br />                         (setq         ret (open fl "w")                                         <br />                                         tt         "Ch\U+01B0\U+01A1ng tr\U+00ECnh cho ph\U+00E9p k\U+00E9o d\U+00E0i \U+0111\U+1ED1i t\U+01B0\U+1EE3ng Line, Polyline, LWPolyline, Arc theo ph\U+00EDa<br />                                                         \n\\U+00A9 Ketxu 3/2017<br />                                                         \nMail : ks.stung@gmail.com<br />                                                         \niCad Group"<br />                                         title "Change Objects Length v1"<br />                         )<br />                         (or *lengDelta* (setq *lengDelta* 10))<br />                         ;List key_label_value default<br />                         (or *lSetting* (setq *lSetting* '(("kStart" "\U+0110\U+1EA7u" "0")("kEnd" "Cu\U+1ED1i" "0")("kBoth" "C\U+1EA3 2 ph\U+00EDa" "1") ("kTotal" "T\U+1ED5ng" "0"))))<br />                         (mapcar<br />                         '(lambda (x) (write-line x ret))<br />                                 (list <br />                                         "Dialog : dialog { "<br />                                         (strcat "label="" title ""; width = 10;fixed_width = true;")<br />                                                 ":edit_box {label ="Chi\U+1EC1u d\U+00E0i :";key = "kDel";}"<br />                                                 " :radio_column{"<br />                                                                 <br />                                                                 (strcat "label="" "Ph\U+00EDa :"  "";")<br />                                                                 (apply 'strcat (mapcar '(lambda (x)(strcat ":radio_button {key="" (car x) "";width=2;label="" (cadr x) "";}")) *lSetting*))                                <br />                                                                 ": spacer { height = 0.2; }"                <br />                                         <br />                                                                 " :text_part {alignment=centered;"<br />                                                                   (strcat "label="" "\\U+00A9 Ketxu - iCad Tools" "";")<br />                                                                 "}"<br />                                                         "}"<br />                                                 ": column {"<br />                                                 ": row {"<br />                                                 "    fixed_width = true;"<br />                                                 "    alignment = centered;"<br />                                                 ":button {label = "Ok";key = "kOK";is_cancel = true;fixed_width = true;width = 1;is_default = 1;}"<br />                                                 ":button {label = "Help";fixed_width = true;width = 1;key = "kHelp";}"                <br />                                                 "}"<br />                                                 "}}"<br />                                 )    <br />                         ) ;_ end of mapcar<br />                         ;Load DCL<br />                         (setq ret (close ret))<br />                         (if (and (not (minusp (setq dcl_id (load_dialog fl))))<br />                                    (new_dialog "Dialog" dcl_id)<br />                           ) ;_ end of and<br />                         (progn<br />                                 <br />                                 ;Init <br />                                 (defun init()<br />                                         (mapcar '(lambda(x)(set_tile (car x) (last x))) *lSetting*)<br />                                         (set_tile "kDel" (rtos *lengDelta*))<br />                                 )<br />                                 (init)<br />                                 <br />                                 ;Get all value when change                <br />                                 (defun Get_Value(/ l1)<br />                                 (setq *lengDelta* (distof (get_tile "kDel")))<br />                                 (mapcar  <br />                                                 '(lambda(x)(list (car x) (cadr x)(get_tile (car x)))) <br />                                                 *lSetting*<br />                                 )                        <br />                                 )<br />                                 (defun        get_len()<br />                                                 (if (not (distof (get_tile "kDel")))(alert "Vui l\U+00F2ng nh\U+1EADp s\U+1ED1 !"))                                <br />                                 )<br />                                 (action_tile "kOK" "(setq ret (Get_value))(done_dialog 4)")<br />                                 (action_tile "kDel" "(get_len)")                <br />                                 (action_tile "kHelp" "(alert tt)")                <br />                                 <br />                           (setq dlg_Exit (start_dialog))          <br />                         ) ;_ end of progn<br />                         ) ;_ end of if<br />                         (unload_dialog dcl_id)  <br />                         (vl-file-delete fl)<br />                         ret<br />                 ))<br />                 );End setq<br />         );End And + Cond <br />         (defun _id(i)(= (last (assoc i *lSetting*)) "1"))<br />         (foreach e (:CM:SS->List s)<br />         (apply 'command<br />                 (append<br />                         (list "_.lengthen")<br />                         (cond         ((_id "kStart") (list "_delta" *lengDelta* (list e (vlax-curve-getstartpoint e)) ""))<br />                                         ((_id "kEnd") (list "_delta" *lengDelta* (list e (vlax-curve-getendpoint e)) ""))<br />                                         ((_id "kBoth") (list "_delta" *lengDelta* (list e (vlax-curve-getendpoint e)) (list e (vlax-curve-getstartpoint e)) ""))<br />                                         ((_id "kTotal") (list "Total" *lengDelta* (list e (vlax-curve-getstartpoint e)) ""))<br />                         )<br />                 )                <br />         ))<br /> )<br /> (T (princ "\nL\U+1ED7i ! Xin li\U+00EAn h\U+1EC7 v\U+1EDBi t\U+00E1c gi\U+1EA3 !") ) <br /> )<br /> (*error* nil)<br /> (princ)<br /> )<br /> <br /> <blockquote>  (vl-load-com)

ketxu

2.   (vl-load-com)
   
3. 
   
4. ;; Open mark and closed mark status
   
5. ;; doc : active document object
   
6. ;; doc = (vla-get-activedocument (vlax-get-acad-object))
   
7. ;;------------------------------------------------------------;;
   
8. 
   
9.   (defun :CM:StartMark ( doc ) (:CM:EndMark doc)
   
10.     (vla-StartUndoMark doc)
    
11.   )
    
12. 
    
13.   ;;------------------------------------------------------------;;
    
14. 
    
15.   (defun :CM:EndMark ( doc )
    
16.     (if (= 8 (logand 8 (getvar 'UNDOCTL)))               
    
17.       (vla-EndUndoMark doc)
    
18.     )
    
19.         ;(princ)
    
20.   )
    
21.         
    
22.   ;;------------------------------------------------------------;;
    
23.   
    
24. (defun :CM:acdoc nil
    
25.     (eval (list 'defun ':CM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))
    
26.     (:CM:acdoc)
    
27. )
    
28. 
    
29. (or *CM:Doc* (setq *CM:Doc* (:CM:acdoc)))
    
30. (defun Start()(:CM:StartMark *CM:DOC*))
    
31. (defun End()(:CM:EndMark *CM:DOC*))

  (vl-load-com)<br /> <br /> ;; Open mark and closed mark status<br /> ;; doc : active document object<br /> ;; doc = (vla-get-activedocument (vlax-get-acad-object)) <br /> ;;------------------------------------------------------------;;<br /> <br />   (defun :CM:StartMark ( doc ) (:CM:EndMark doc)<br />     (vla-StartUndoMark doc)<br />   )<br /> <br />   ;;------------------------------------------------------------;;<br /> <br />   (defun :CM:EndMark ( doc )<br />     (if (= 8 (logand 8 (getvar 'UNDOCTL)))                <br />       (vla-EndUndoMark doc)<br />     )<br />         ;(princ)<br />   )<br />         <br />   ;;------------------------------------------------------------;;<br />   <br /> (defun :CM:acdoc nil<br />     (eval (list 'defun ':CM:acdoc 'nil (vla-get-activedocument (vlax-get-acad-object))))<br />     (:CM:acdoc)<br /> ) <br /> <br /> (or *CM:Doc* (setq *CM:Doc* (:CM:acdoc)))<br /> (defun Start()(:CM:StartMark *CM:DOC*))<br /> (defun End()(:CM:EndMark *CM:DOC*))

yuping913

ketxu 发表于 2019-4-16 00:57

命令: col
no function definition: :CM:SS-SELECT

ketxu

Sorry, it's in my library function, and credit for Lee-mac ^^

2. ;; ssget  -  Lee Mac
   
3. ;; A wrapper for the ssget function to permit the use of a custom selection prompt
   
4. ;; msg - [str] selection prompt
   
5. ;; arg - [lst] list of ssget arguments
   
6. 
   
7. (defun LM:ssget ( msg arg / sel )
   
8.     (princ msg)
   
9.     (setvar 'nomutt 1)
   
10.     (setq sel (vl-catch-all-apply 'ssget arg))
    
11.     (setvar 'nomutt 0)
    
12.     (if (not (vl-catch-all-error-p sel)) sel)
    
13. )
    
14. (setq :CM:SS-Select LM:ssget)

;; ssget  -  Lee Mac<br /> ;; A wrapper for the ssget function to permit the use of a custom selection prompt<br /> ;; msg - [str] selection prompt<br /> ;; arg - [lst] list of ssget arguments<br /> <br /> (defun LM:ssget ( msg arg / sel )<br />     (princ msg)<br />     (setvar 'nomutt 1)<br />     (setq sel (vl-catch-all-apply 'ssget arg))<br />     (setvar 'nomutt 0)<br />     (if (not (vl-catch-all-error-p sel)) sel)<br /> )<br /> (setq :CM:SS-Select LM:ssget)

Akifans

我也遇到这个问题了