[求助]：■寻求两个程序 急用 谢谢■

zhuquanmao

本人寻求以下程序：
程序1。可以把直线、圆变成可由使用人控制宽度的多义线
程序2。选择一个单行文本，然后再选择文本实体，这些实体的内容就变成了第一个选择的文本实体的内容。
谢谢帮助！急用

自由的鱼

程序2

Option Explicit

Sub tt()
Dim pnt As Variant
Dim ent As AcadEntity
Dim stxt As String
Dim mtxt As String
Dim sset As AcadSelectionSet
Dim i As Integer
For i = 0 To ThisDrawing.SelectionSets.Count - 1
    ThisDrawing.SelectionSets.Item(i).Clear
    ThisDrawing.SelectionSets.Item(i).Delete
Next
ThisDrawing.Utility.GetEntity ent, pnt, "choose"
stxt = ent.TextString
Set sset = ThisDrawing.SelectionSets.Add("tt")

sset.SelectOnScreen
For i = 0 To sset.Count - 1
sset.Item(i).TextString = stxt
Next
End Sub

zhuquanmao

怎么用啊 呵呵 怎么加载 执行什么命令呢

自由的鱼

保存成DVB文件，VBAMAN命令加载，VBARUN命令运行！

david96007

这些程序论坛里都有，还是自己找吧！

逐月飞鸿

1.文本编辑程序MM，类似格式刷，用来刷文本，被他刷过文本内容就和第一个一样了。
(defun c:MM (/ LEN MODELTXT SSTEXT TXTENT)
  (prompt "\n请选择源文字:")
  (setq sstext (ssget '((0 . "text"))))
  (if sstext
    (progn
      (setq modeltxt (cdr (assoc 1 (entget (ssname sstext 0)))))
      (repeat (setq len (sslength sstext))
(setq txtent (ssname sstext (setq len (1- len))))
(entmod
   (subst (cons 1 modeltxt)
   (assoc 1 (entget txtent))
   (entget (ssname sstext len))
   )
)
(entupd txtent)
      )
    )
  )
（PRINC）
)
;=============================================================================
;;;Zpm-pw.lsp

;;;本程序用于修改line,pline,arc,circle线的宽度
;;;-------------------------------------------------------------------
;;;改pline线的宽度
(defun pl_e (pline width)
  (command "pedit" pline "w" width "")
)
;==================================================================
;;;改line,arc线宽度                  
(defun l_e (line width)
  (command "pedit" line "" "w" width "")
)
;;;===================================================================
;;;改circle宽度
(defun pc_w (circle width / ed la cen rad d1 d2)
  (setq ed (entget circle))                ;取得实体参数集
  (setq la (cdr (assoc 8 ed)))                ;获得圆的当前层
  (setq cen (cdr (assoc 10 ed)))        ;获得圆的圆心
  (setq cen (trans cen circle 1))        ;将圆心坐标CEN由目标坐系
                                        ;转到当前用户坐标系
  (setq rad (cdr (assoc 40 ed)))        ;获得圆的半径
  (setq d1 (- (+ rad rad) width))        ;内径
  (setq d2 (+ (+ rad rad) width))        ;外径
  (command "layer" "s" la "")
  (entdel circle)
  (command "donut" d1 d2 cen "")
)
;;;===================================================================
(defun c:LW (/ osm width ss number i ename etype)
  (setvar "cmdecho" 0)
  (setq osm (getvar "osmode"))
  (setvar "osmode" 0)

  (if (null default-w)
    (setq default-w "0.5")
  )
  (setq width (getreal (strcat "请输入线宽<" default-w ">:")))
  (if (null width)
    (setq width (distof default-w))
    (setq default-w (rtos width 2 2))
  )
  (print)
  (prompt "请选择对象：")
  (setq ss (ssget))
  (if (null ss)
    (princ)
    (progn
      (setq number (sslength ss))
      (setq i 0)
      (repeat number
        (progn
          (setq ename (ssname ss i))
          (setq etype (cdr (assoc 0 (entget ename))))
          (if
            (= etype "CIRCLE")
             (pc_w ename width)
             (if
               (or (= etype "LWPOLYLINE") (= etype "POLYLINE"))
                (pl_e ename width)
                (if
                  (or (= etype "LINE") (= etype "ARC"))
                   (l_e ename width)
                );END IF
             );END IF
          );END IF
          (setq i (1+ i))
        );END PROGN
      );END REPEAT
    );END PROGN
  );END IF

  (setvar "cmdecho" 1)
  (setvar "osmode" osm)
  (princ)
)