[已解决]：想写一个快速改变图元的线型比例的程序（已解决）

Wildcat · 发表于 2007-3-8 16:16:58

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

您需要登录才可以下载或查看，没有账号？立即注册

×

想写一个快速改变图元的线型比例的程序，编程思路是通过在图元列表内新加入一个（48 。X）的点对表实现。但在实际操作中发现只对圆、弧、直线有作用，对PLINE和SPLINE无作用。为何？
下面是程序的一部分｛只针对图元列表内还没有（48 。X）点对表的图元，也就是赋予了线型，但未作线性比修改的图元｝
(defun c:temp ()
  (setq en (car (entsel "\n请选择直线、复合线、圆、弧、或填充："))
en_list (entget en)
      scale_new (getreal "\n输入新的线性比例：")
scale_new (cons 48 scale_new)
en_list    (cons scale_new en_list)
  )
  (entmod en_list)
  (prin1)
)
程序是加了（48 。X），但复查作了修改的PLINE和SPLINE，却没发现有（48 。X），为何？谢谢。

carrot1983 · 发表于 2007-3-8 18:15:57

以下是选择"line" 原来的线型比例是10.0
用了斑主的程序，输入4以后就变成下面的样子了。而图面上的线型没变，"line"的属性也没变，
还是10.0

((48 . 4.0) (-1 . <图元名: 7ef50e78>) (0 . "LINE") (330 . <图元名: 7ef50cf8>) (5 . "87")
(100 . "AcDbEntity") (67 . 0) (410 . "Model") (8 . "0") (6 . "ACAD_ISO02W100") (48 . 10.0)
(100 . "AcDbLine") (10 315.611 476.916 0.0) (11 1642.21 740.283 0.0) (210 0.0 0.0 1.0))

复制代码

"line" "arc" "CIRCLE" "SPLINE"和"LWPOLYLINE"里面原来就有48的组码，是不是该用替代的啊"subst"

以下是改过的。运行没问题，可以成功。
[php](defun c:temp ()
(setq en (car (entsel "\n请选择直线、复合线、圆、弧、或填充："))
en_list (entget en)
scale_new (getreal "\n输入新的线性比例：")
en_list (subst (cons 48 scale_new) (assoc 48 en_list) en_list)
)
(entmod en_list)
(prin1)
)
[/php]

wangyq · 发表于 2007-3-8 19:03:08

命令能用，但是不起作用，是什么原因？

Wildcat · 发表于 2007-3-8 19:25:05

最初由 carrot1983 发布
[B]以下是选择"line" 原来的线型比例是10.0
用了斑主的程序，输入4以后就变成下面的样子了。而图面上的线型没变，"line"的属性也没变，
还是10.0
[code]
((48 . 4.0) (-1 . <图元名: 7ef50e78>) (0 . "LINE") (330 ... [/B]

谢谢您。
我问题的关键如何在从未设定线型比例（图元列表内没有(48 .X)这个点对表）的“PLINE”和“SPLINE”上，加入（48 .X）点对表，以达到改变线型比例的目的。
您举的那个例子，是“LINE”且构成图元的列表内已经（48 。10）了，所以我的代码未能起效。
我完整的代码如下：
[PHP](defun c:TEMP ()
 (setq en (car (entsel "\n请选择直线、复合线、圆、弧、填充或标注："))
en_list (entget en)
en_0 (cdr (assoc 0 en_list))
 )
 (redraw en 3)
 (if (or (= en_0 "LINE")
 (= en_0 "LWPOLYLINE")
 (= en_0 "CIRCLE")
 (= en_0 "ARC")
 (= en_0 "DIMENSION")
 (= en_0 "HATCH")
 (= en_0 "SPLINE")
 )
(progn
 (setq en_48 (assoc 48 en_list)
 en_48a (cdr en_48)
 )
 (if (= en_0 "DIMENSION")
(progn
 (setq obj (vlax-ename->vla-object en)
oldscale (vla-get-linearscalefactor obj)
txt (strcat "请输入新的线性比例<" (rtos oldscale) ">:")
 )
 (setq newscale (getreal txt))
 (if (null newscale)
 (progn (princ "保持原有比例无变化") (prin1))
 (vla-put-linearscalefactor obj newscale)
 )
)
 )
 (if (and (/= en_0 "DIMENSION") (null en_48))
(progn
 (setq scale_new (getreal "\n输入新的线性比例：")
scale_new (cons 48 scale_new)
en_list (cons scale_new en_list)
 )
 (entmod en_list)
 (prin1)
)
 )
 (if (/= en_48 nil)
(progn
 (setq txt (rtos en_48a 2 2)
stxt (strcat "请输入新的线性比例<" txt ">:")
scale_new (getreal stxt)
 )
 (if (null scale_new)
 (progn (princ "保持原有比例无变化") (prin1))
 (progn
 (setq scale_new (cons 48 scale_new)
 en_list (subst scale_new (assoc 48 en_list) en_list)
 )
 (entmod en_list)
 (prin1)
 )
 )
)
 )
)
(princ "\n所选择不是直线、复合线、圆、弧、填充或标注")
 )
 (redraw en 4)
)[/PHP]
我最终的目的是想写一个“选标注尺寸，而是改标注线性比例，选填充则改填充比例，选线条，则改线型比例的程序。现在就差“PLINE”“SPLINE”这个未能搞定，“HATCH”的问题似乎和“PLINE”“SPLINE”是同一个问题。

carrot1983 · 发表于 2007-3-8 20:47:28

好奇怪。。呵呵，可能是我先用一楼的程序运行完后，才有48的。然后再用二楼的程序改。太奇怪了，我第一次用二楼的程序时，不懂怎么搞的，pline和spline都可以改的。
现在再回头编，就改不了pline和spline，，，，晕了
[php]
(defun c:t1 (/ en_list scale_new abc en_48)
  (setq en_list (entget (car (entsel "\n请选择直线、复合线、圆、弧、或填充："))))
  (setq scale_new (getreal "\n输入新的线性比例："))
  (setq abc (cons 48 scale_new))
  (setq en_48 (assoc 48 en_list))
  (if (null en_48)
(progn
   (setq en_list (cons abc en_list))
   (setq en_list (subst abc (assoc 48 en_list) en_list))
)
(setq en_list (subst abc (assoc 48 en_list) en_list))
  )
  (entmod en_list)
  (prin1)
)
[/php]
如斑主说的那几种不行。。。
谢谢楼主，，向您学习了。
,期待答案。。

Wildcat · 发表于 2007-3-9 12:54:48

问题已解决，谢谢论坛朋友们的帮助。特别谢谢kohi
程序的功能，根据所选不同的对象作不同的比例修改。
情况一、选中直线、弧线、圆、复合线、多义线，则作线型比例的修改。
情况二、选中标注尺寸，则作标注尺寸的标注线性比修改。
情况三、选中填充，则作填充比例的修改。

[PHP](defun c:temp ()
 (setq en (car (entsel "\n请选择直线、复合线、圆、弧、填充或标注："))
en_list (entget en)
en_0 (cdr (assoc 0 en_list))
 )
 (redraw en 3)
 (if (or (= en_0 "LINE")
 (= en_0 "LWPOLYLINE")
 (= en_0 "CIRCLE")
 (= en_0 "ARC")
 (= en_0 "DIMENSION")
 (= en_0 "HATCH")
 (= en_0 "SPLINE")
 )
(progn
 (setq en_48 (assoc 48 en_list)
 en_48a (cdr en_48)
 )
 (if (= en_0 "DIMENSION")
(progn
 (setq obj (vlax-ename->vla-object en)
oldscale (vla-get-linearscalefactor obj)
txt (strcat "请输入新的线性比例<" (rtos oldscale) ">:")
 )
 (setq newscale (getreal txt))
 (if (null newscale)
 (progn (princ "保持原有比例无变化") (prin1))
 (vla-put-linearscalefactor obj newscale)
 )
)
 )
 (if (and (/= en_0 "DIMENSION") (/= en_0 "HATCH"))
(progn (changescale))
 )
 (if (= en_0 "HATCH")
(progn
 (setq obj (vlax-ename->vla-object en)
oldscale (vla-get-PatternScale obj)
txt (strcat "请输入新的线性比例<" (rtos oldscale) ">:")
 )
 (setq newscale (getreal txt))
 (if (null newscale)
 (progn (princ "保持原有比例无变化") (prin1))
 (vla-put-PatternScale obj newscale)
 )
)
 )
)
(princ "\n所选择不是直线、复合线、圆、弧、填充或标注")
 )
 (redraw en 4)
)
(defun changescale ()
 (setq obj (vlax-ename->vla-object en)
oldscale (vla-get-LinetypeScale obj)
stxt (strcat "请输入新的线性比例<" (rtos oldscale) ">:")
 )
 (setq scale_new (getreal stxt))
 (if (null scale_new)
(progn (princ "保持原有比例无变化") (prin1))
(progn
 (vla-put-LinetypeScale obj scale_new)
 (prin1)
)
 )
)
[/PHP]

eachy · 发表于 2007-3-9 18:51:04

整理了下

(defun c:tt (/ s e obj on oldscale newscale)
(princ "\n请选择直线、复合线、圆、弧、填充或标注：")
(if (setq
s
(ssget ":S"
'((0 . "Line,*polyline,arc,circle,hatch,dimension"))
)
)
(progn
(setq e (ssname s 0)
obj (vlax-ename->vla-object e)
on (vla-get-objectname obj)
)
(cond
((not (vl-catch-all-error-p
(setq oldscale (vl-catch-all-apply
'vla-get-linearscalefactor
(list obj)
)
)
)
)
)
((not (vl-catch-all-error-p
(setq oldscale
(vl-catch-all-apply 'vla-get-patternscale (list obj))
)
)
)
)
(t
(setq
oldscale (vl-catch-all-apply
'vla-get-linetypescale
(list obj)
)
)
)
)
(setq newscale (getdist (strcat "\n请输入新的线性比例<"
(rtos oldscale)
">:"
)
)
)
(if newscale
(cond
((wcmatch on "*Dim*")
(vla-put-linearscalefactor obj newscale)
)
((wcmatch on "*Hatch")
(vla-put-PatternScale obj newscale)
)
(t
(vla-put-LinetypeScale obj newscale)
)
)
(princ "\n保持原有比例无变化!")
)
)
(princ "\n所选择不是直线、复合线、圆、弧、填充或标注!")
)
(princ)
)

(defun c:tt (/ s e obj on oldscale newscale) 
  (princ "\n请选择直线、复合线、圆、弧、填充或标注：") 
  (if (setq 
        s 
         (ssget        ":S" 
                '((0 . "Line,*polyline,arc,circle,hatch,dimension")) 
         ) 
      ) 
    (progn 
      (setq e        (ssname s 0) 
            obj        (vlax-ename->vla-object e) 
            on        (vla-get-objectname obj) 
      ) 
      (cond 
        ((not (vl-catch-all-error-p 
                (setq oldscale (vl-catch-all-apply 
                                 'vla-get-linearscalefactor 
                                 (list obj) 
                               ) 
                ) 
              ) 
         ) 
        ) 
        ((not (vl-catch-all-error-p 
                (setq oldscale 
                       (vl-catch-all-apply 'vla-get-patternscale (list obj)) 
                ) 
              ) 
         ) 
        ) 
        (t 
         (setq 
           oldscale (vl-catch-all-apply 
                      'vla-get-linetypescale 
                      (list obj) 
                    ) 
         ) 
        ) 
      ) 
      (setq newscale (getdist (strcat "\n请输入新的线性比例<" 
                                      (rtos oldscale) 
                                      ">:" 
                              ) 
                     ) 
      ) 
      (if newscale 
        (cond 
          ((wcmatch on "*Dim*") 
           (vla-put-linearscalefactor obj newscale) 
          ) 
          ((wcmatch on "*Hatch") 
           (vla-put-PatternScale obj newscale) 
          ) 
          (t 
           (vla-put-LinetypeScale obj newscale) 
          ) 
        ) 
        (princ "\n保持原有比例无变化!") 
      ) 
    ) 
    (princ "\n所选择不是直线、复合线、圆、弧、填充或标注!") 
  ) 
  (princ) 
)

雨箭风刀 · 发表于 2007-3-9 21:08:09

[php]
(defun c:xx (/ ATT E M NEWSCALE OBJ OLDSCALE ON S)
 (if
(setq s (ssget ":S" '((0 . "Line,*polyline,arc,circle,hatch,dimension"))))
 (progn
 (setq m '(("AcDbAlignedDimension" . linearscalefactor)
 ("AcDbHatch" . patternscale)
 (nil . linetypescale)
 )
 e (ssname s 0)
 obj (vlax-ename->vla-object e)
 on (vla-get-objectname obj)
 )
 (or (setq oldscale (assoc on m))
 (setq oldscale (last m))
 )
 (setq att (cdr oldscale)
 oldscale (vlax-get obj att)
 newscale (getdist (strcat "\n 请输入新的线性比例<" (rtos oldscale) ">:"))
 )
 (if newscale (vlax-put obj att newscale) )
 )
 )(princ)
)
[/php]

Wildcat · 发表于 2007-3-9 21:12:02

谢谢大家，经您们整理完，程序化简了非常多。
您们的程序里使用了大量VLISP函数，正是我想学习的，市面上好的VLISP教学书基本没有，我购买了一本《AUTOCAD LISP/VLISP函数库查询辞典》，现在可以对照您的程序来学习。如果有什么不明白，再向各位请教，非常感谢。

Wildcat · 发表于 2007-3-9 21:23:51

[PHP](setq newscale (getdist (strcat "\n请输入新的线性比例<"
 (rtos oldscale)
 ">:"
 )
 )
 )[/PHP]

请问为什么上面加入getdist这个函数呢？直接输入数字似乎比鼠标点两下更为方便哦。是不是有什么窍门在里面呀？

雨箭风刀 · 发表于 2007-3-9 21:58:39

getdist 可以直接输入数字,也可以鼠标点取两点定距离.
多一个选择有什么不好?

carrot1983 · 发表于 2007-3-10 12:02:17

向楼上几位大师学习了。可能是小弟不懂VL函数（2000以上才能用的），所以觉得好像想编的东西都很难编出来。
像楼上的程序，用R14下能用的lisp语言，能编的出来吗？
看了8楼的大师的代码，我想应该可以吧。学习了，好羡慕啊。。。

YUSHUIJING2005 · 发表于 2009-6-25 22:18:10

好棒好棒，谢谢楼主

carrot1983 · 发表于 2009-6-25 23:11:45

哇，两年前的贴子。。。
有点不认识两年前的我。
哈哈。。。

账号		自动登录	找回密码
密码			立即注册

[已解决] [已解决]：想写一个快速改变图元的线型比例的程序（已解决）

马上注册，结交更多好友，享用更多功能，让你轻松玩转社区。

相关帖子

挺好的