多线mline绘制vla方法

dcl1214

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

(defun $make-mline$ (pts lst)<br />                     ;($make-mline$(list (getpoint)(getpoint))(list(cons "比例" "随便")))<br /> <br />   (setvar 'CELTSCALE 1.0)<br />   (setvar 'LTSCALE 1.0)<br />   (setvar 'PSLTSCALE 1.0)<br />   (setvar 'MEASUREINIT 1)<br />   (setvar 'MEASUREMENT 1)<br />   (setvar 'CMLSCALE 20.0)<br />   (setvar 'LUNITS 2)<br />   (SETVAR "DIMLFAC" 1)<br />   (if (and (= (rem (length (car pts)) 3) 0)<br />            (>= (length pts) 2)<br />       )<br />     (PROGN (setq obj (vl-catch-all-apply<br />                        'vla-addmline<br />                        (list<br />                          (vlax-get-property<br />                            (vla-get-activedocument (vlax-get-acad-object))<br />                            (if (= 1 (getvar 'CVPORT))<br />                              'Paperspace<br />                              'Modelspace<br />                            )<br />                          )<br />                          (vl-catch-all-apply<br />                            'vlax-make-variant<br />                            (list<br />                              (vl-catch-all-apply<br />                                'vlax-safearray-fill<br />                                (list<br />                                  (vl-catch-all-apply<br />                                    'vlax-make-safearray<br />                                    (list<br />                                      vlax-vbDouble<br />                                      (cons 1 (* 3 (length pts)))<br />                                    )<br />                                  )<br />                                  (apply 'append pts)<br />                                )<br />                              )<br />                            )<br />                          )<br />                        )<br />                      )<br />            )<br />            (vl-catch-all-apply<br />              'vla-put-MLineScale<br />              (list<br />                obj<br />                (cdr (assoc "比例" lst))<br />              )<br />            )<br />     )<br />   )<br />   (SETQ ENT (VL-CATCH-ALL-APPLY 'VLAX-ENAME->VLA-OBJECT (LIST OBJ)))<br />   (IF (VL-CATCH-ALL-ERROR-P ENT)<br />     (SETQ ENT NIL)<br />   )<br />   ent<br /> )<br />

guosheyang

感谢杜总的分享！

magicheno

感谢大佬分享

自贡黄明儒

关于mline的帖子很少，给楼主点赞。
mline首先要进行设置，这才是关键。

dcl1214

自贡黄明儒 发表于 2024-4-17 07:12
关于mline的帖子很少，给楼主点赞。
mline首先要进行设置，这才是关键。

增加了变量设置，您给审核一下

自贡黄明儒

dcl1214 发表于 2024-4-17 08:46
增加了变量设置，您给审核一下

楼主客气了，也高看我了。当初我画型钢时，也想用mline来实现，当时看了一下样式设置，太复杂，也没有找到方法，就放弃了。

寒潮大冬瓜

很好→很棒！很好~很棒！！很好……很棒！！！

被承包的东子

杜总，这句话是不是错了啊  (SETQ ENT (VL-CATCH-ALL-APPLY 'VLAX-ENAME->VLA-OBJECT (LIST OBJ)))我觉得应该是(SETQ ENT (VL-CATCH-ALL-APPLY 'vlax-vla-object->ename  (LIST OBJ)))

`中微子

谢谢共享源码正需要,如何把对正方式改为上,现在的对正是无.
变量是CMLJUST