[源码] 多线mline绘制vla方法

admin

1. (defun $make-mline$ (pts lst)
   
2.                                         ;($make-mline$(list (getpoint)(getpoint))(list(cons "比例" "随便")))
   
3.   (if (and (= (rem (length (car pts)) 3) 0)
   
4.            (>= (length pts) 2)
   
5.       )
   
6.     (PROGN (setq obj (vl-catch-all-apply
   
7.                        'vla-addmline
   
8.                        (list
   
9.                          (vlax-get-property
   
10.                            (vla-get-activedocument (vlax-get-acad-object))
    
11.                            (if (= 1 (getvar 'CVPORT))
    
12.                              'Paperspace
    
13.                              'Modelspace
    
14.                            )
    
15.                          )
    
16.                          (vl-catch-all-apply
    
17.                            'vlax-make-variant
    
18.                            (list
    
19.                              (vl-catch-all-apply
    
20.                                'vlax-safearray-fill
    
21.                                (list
    
22.                                  (vl-catch-all-apply
    
23.                                    'vlax-make-safearray
    
24.                                    (list
    
25.                                      vlax-vbDouble
    
26.                                      (cons 1 (* 3 (length pts)))
    
27.                                    )
    
28.                                  )
    
29.                                  (apply 'append pts)
    
30.                                )
    
31.                              )
    
32.                            )
    
33.                          )
    
34.                        )
    
35.                      )
    
36.            )
    
37.            (vl-catch-all-apply
    
38.              'vla-put-MLineScale
    
39.              (list
    
40.                obj
    
41.                (cdr (assoc "比例" lst))
    
42.              )
    
43.            )
    
44.     )
    
45.   )
    
46.   (SETQ ENT (VL-CATCH-ALL-APPLY 'VLAX-ENAME->VLA-OBJECT (LIST OBJ)))
    
47.   (IF (VL-CATCH-ALL-ERROR-P ENT)
    
48.     (SETQ ENT NIL)
    
49.   )
    
50.   ent
    
51. )

复制代码