请高手帮忙修改下源码，素土夯实！

huxu823 · 发表于 2024-5-9 17:33

修改要求如下：
1、不管当前图层是什么，始终使用0图层，颜色线型线宽全部随层、线型比例为1，且不改变当前图层，避免需要重复切换图层。
2、画完以后整个图形成一个图块，图块置于0图层，块名设置为“素土夯实”。

(if (null vlax-dump-object) (vl-load-com));;将 Visual LISP 扩展功能加载到 AutoLISP----0000级加载
;;常量定义
(setq *Acad* (vlax-get-acad-object)
*AcDocument* (vla-get-activedocument *Acad*) ; 获取当前图档指针
*Model-Space* (vla-get-modelspace *AcDocument*)
*Paper-Space* (vla-get-PaperSpace *AcDocument*)
*BLKS* (vla-get-Blocks *AcDocument*)
*LAYS* (vla-get-Layers *AcDocument*)
*ACLYS* (vla-get-activeLayer *AcDocument*)
*LTS* (vla-get-Linetypes *AcDocument*)
pi2 (* pi 0.5)
pi4 (* pi 0.25)
3pi4 (* 0.75 pi)
2pi (+ pi pi)
3pi2 (+ 3pi4 3pi4) ;; (* 1.5 pi)
5pi4 (+ pi pi4) ;;(* 1.25 pi)
7pi4 (+ 3pi2 pi4) ;;(* 1.75 pi)
)
;;素土夯实 rammed-earth-------------c:ram-soil
(defun c:ST (/ cmde plis len ang hi num p1 p2 p3 p4 e0 pt1 pt2 pt22 pt3 pt33 pt4 pt44 pk11 pk2 pk22 pk3 pk33 n)
(setq cmde (getvar "CMDECHO"))
(setvar "CMDECHO" 0)
(setq p1 (getpoint "\n 第一角点: ") p2 (getcorner p1 "\n 第二角点: "))
(setq
plis (format2pt p1 p2)
p1 (car plis)
p2 (cadr plis)
p3 (caddr plis)
p4 (cadddr plis)
len (distance p1 p2)
ang (angle p1 p2)
hi (distance p1 p4)
num (fix (/ len (* 2.0 hi))) ;;填充单元数
e0 (entlast)
)
(setq pt1 (polar p4 ang hi))
(command ".UNDO" "BE")
(makeline pt1 p1)
(setq pt2 (polar pt1 ang (* 0.5 hi)))
(setq pt22 (polar p1 ang (* 0.5 hi)))
(makeline pt2 pt22)
(setq pt3 (polar pt2 ang (* 0.5 hi)))
(setq pt33 (polar pt22 ang (* 0.5 hi)))
(makeline pt3 pt33)
(setq pt4 (polar pt3 ang hi))
(setq pt44 (polar pt33 ang hi))
(setq pk11 (pertolinecz pt3 pt4 pt44))
(makeline pt3 pk11)
(setq pk2 (polar pt3 (- ang 3pi4) (* 0.47 hi)))
(setq pk22 (pertolinecz pk2 pt4 pt44))
(makeline pk2 pk22)
(setq pk3 (polar pt33 (+ ang pi4) (* 0.47 hi)))
(setq pk33 (polar pt33 ang (* 0.665 hi)))
(makeline pk3 pk33)
(setq ss (last_ent e0))
(slch:lwpolyline (list p4 (polar p4 ang (+ (* num 2.0 hi) hi))) nil ByLayer "0" ByLayer nil)
(setq n 0)
(while (> num 1)
(setq p2 (polar p4 ang (* 2.0 hi (setq n (1+ n)))))
(command "_copy" ss "" p4 p2)
(setq num (1- num))
)
(command "_.undo" "_end")
(setq ss (last_ent e0))
(command "_move" ss "" (cadr (grread 5)) pause)
(setvar "CMDECHO" cmde)
(princ)
)
;;--------函数部分-------
;取得图元参数值内容----------（一级）-------
;;(setq h (dxf1 ent 40))
; ent 为实体名或实体entget，
(defun dxf1 (ent i / tmp)
(if (= (type ent) 'ENAME)
(setq ent (entget ent '("*")))
)
(setq tmp (cdr (assoc i ent)))
(if (null tmp)
(cond
((= i 66) 0)
((= i 62) 256)
((= i 370) (setq tmp -1))
((= i 6) "ByLayer")
)
tmp
)
)
;; 函数取得en之后生成的所有图元的选择集-----------(一级)-----------
(defun last_ent (en / ss)
(if en
(progn
(setq ss (ssadd))
(while (setq en (entnext en))
(if (not (member (dxf1 en 0) '("ATTRIB" "VERTEX" "SEQEND")))
(ssadd en ss)
)
)
(if (zerop (sslength ss))(setq ss nil))
ss
)
(ssget "_x")
)
)
;计算cp到p1 p2的垂足点-----------（一级）---------
(defun pertolinecz (cp p1 p2 / norm)
(setq norm (mapcar '- p2 p1)
p1 (trans p1 0 norm)
cp (trans cp 0 norm)
)
(trans (list (car p1) (cadr p1) (caddr cp)) norm 0)
)
;-------生成一条line ----（一级)------------------------
;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z)
(defun makeline (pt1 pt2)
(entmakex (list
'(0 . "line")
(cons 10 pt1)
(cons 11 pt2))
)
)
;;两点求四点矩形表:(左下右下右上左上)------(一级)-----------
(defun format2pt (pt1 pt2 / x1 x2 xx y1 y2 yy)
(setq x1 (car pt1))
(setq x2 (car pt2))
(setq y1 (cadr pt1))
(setq y2 (cadr pt2))
(if (< x2 x1)
(progn
(setq xx x1)
(setq x1 x2)
(setq x2 xx)
)
)
(if (< y2 y1)
(progn
(setq yy y1)
(setq y1 y2)
(setq y2 yy)
)
)
(list (list x1 y1) (list x2 y1) (list x2 y2) (list x1 y2))
)
;点表生成多段线--------(一级)----------------
;线宽=nil，线宽为0 ;是否闭合=nil，不闭合 ;图层=nil，为当前图层 ;颜色=nil，为当前图层颜色 ;线型比例=nil，为1
;(slch:lwpolyline 点表是否闭合线宽图层颜色线型比例)
;(slch:lwpolyline (list (1 2) (2 3)) T 2 "中心线" 6 5)
(defun slch:lwpolyline (lst dxf70 plwid lay lwplcol lwplbili)
(entmake
(append
(list
'(0 . "LWPOLYLINE") ;多段线
'(100 . "AcDbEntity")
'(100 . "AcDbPolyline")
(cons 90 (length lst)) ;点表
(if (= dxf70 T)
(cons 70 1) ;是否闭合
(cons 70 0)
)
(if plwid
(cons 43 plwid) ;线宽
(cons 43 0)
)
(if lay
(cons 8 lay) ;图层
(cons 8 (getvar "clayer"))
)
(if lwplcol
(cons 62 lwplcol) ;颜色
(cons 62 256)
)
(if lwplbili
(cons 48 lwplbili) ;线型比例
(cons 48 (* 0.01 (getvar "DIMLFAC")))
)
)
(mapcar '(lambda (pt) (cons 10 pt)) lst)
)
)
)

(if (null vlax-dump-object) (vl-load-com));;将 Visual LISP 扩展功能加载到 AutoLISP----0000级加载 
;;常量定义 
(setq *Acad* (vlax-get-acad-object) 
  *AcDocument* (vla-get-activedocument *Acad*)  ; 获取当前图档指针 
  *Model-Space* (vla-get-modelspace *AcDocument*) 
  *Paper-Space* (vla-get-PaperSpace *AcDocument*) 
  *BLKS* (vla-get-Blocks *AcDocument*) 
  *LAYS* (vla-get-Layers *AcDocument*) 
  *ACLYS* (vla-get-activeLayer *AcDocument*) 
  *LTS* (vla-get-Linetypes *AcDocument*) 
  pi2     (* pi 0.5) 
  pi4     (* pi 0.25) 
  3pi4   (* 0.75 pi) 
  2pi     (+ pi pi) 
  3pi2   (+ 3pi4 3pi4)  ;; (* 1.5 pi) 
  5pi4   (+ pi pi4)  ;;(* 1.25 pi) 
  7pi4   (+ 3pi2 pi4) ;;(* 1.75 pi) 
) 
 
 
;;素土夯实 rammed-earth-------------c:ram-soil 
(defun c:ST (/ cmde plis len ang hi num p1 p2 p3 p4 e0 pt1 pt2 pt22 pt3 pt33 pt4 pt44 pk11 pk2 pk22 pk3 pk33 n) 
  (setq cmde (getvar "CMDECHO")) 
  (setvar "CMDECHO" 0) 
  (setq p1 (getpoint "\n 第一角点: ") p2 (getcorner p1 "\n 第二角点: ")) 
  (setq 
    plis (format2pt p1 p2) 
    p1 (car plis) 
    p2 (cadr plis) 
    p3 (caddr plis) 
    p4 (cadddr plis) 
    len (distance p1 p2) 
    ang (angle p1 p2) 
    hi (distance p1 p4) 
    num (fix (/ len (* 2.0 hi)))  ;;填充单元数 
    e0 (entlast) 
  ) 
  (setq pt1 (polar p4 ang hi)) 
  (command ".UNDO" "BE") 
  (makeline pt1 p1) 
  (setq pt2 (polar pt1 ang (* 0.5 hi))) 
  (setq pt22 (polar p1 ang (* 0.5 hi))) 
  (makeline pt2 pt22) 
  (setq pt3 (polar pt2 ang (* 0.5 hi))) 
  (setq pt33 (polar pt22 ang (* 0.5 hi))) 
  (makeline pt3 pt33) 
  (setq pt4 (polar pt3 ang hi)) 
  (setq pt44 (polar pt33 ang hi)) 
  (setq pk11 (pertolinecz pt3 pt4 pt44)) 
  (makeline pt3 pk11) 
  (setq pk2 (polar pt3 (- ang 3pi4) (* 0.47 hi))) 
  (setq pk22 (pertolinecz pk2 pt4 pt44)) 
  (makeline pk2 pk22) 
  (setq pk3 (polar pt33 (+ ang pi4) (* 0.47 hi))) 
  (setq pk33 (polar pt33 ang (* 0.665 hi))) 
  (makeline pk3 pk33) 
  (setq ss (last_ent e0)) 
  (slch:lwpolyline (list p4 (polar p4 ang (+ (* num 2.0 hi) hi))) nil ByLayer "0" ByLayer nil) 
  (setq n 0) 
  (while (> num 1) 
    (setq p2 (polar p4 ang (* 2.0 hi (setq n (1+ n))))) 
    (command "_copy" ss "" p4 p2) 
    (setq num (1- num)) 
  ) 
  (command "_.undo" "_end") 
  (setq ss (last_ent e0)) 
  (command "_move" ss "" (cadr (grread 5)) pause) 
  (setvar "CMDECHO" cmde) 
  (princ) 
) 
 
;;--------函数部分------- 
 
;取得图元参数值内容----------（一级）------- 
;;(setq h (dxf1 ent 40)) 
; ent 为实体名或实体entget， 
(defun dxf1 (ent i / tmp) 
  (if (= (type ent) 'ENAME) 
    (setq ent (entget ent '("*"))) 
  ) 
  (setq tmp (cdr (assoc i ent))) 
  (if (null tmp) 
    (cond 
    ((= i 66) 0) 
      ((= i 62) 256) 
      ((= i 370) (setq tmp -1)) 
      ((= i 6) "ByLayer") 
    ) 
    tmp   
  ) 
) 
;; 函数取得en之后生成的所有图元的选择集-----------(一级)----------- 
(defun last_ent (en / ss) 
  (if en 
    (progn 
      (setq ss (ssadd)) 
      (while (setq en (entnext en)) 
        (if (not (member (dxf1 en 0) '("ATTRIB" "VERTEX" "SEQEND"))) 
          (ssadd en ss) 
        )                              
      )                               
      (if (zerop (sslength ss))(setq ss nil)) 
      ss 
    )                                 
    (ssget "_x") 
  )                                    
) 
;计算cp到p1 p2的垂足点-----------（一级）--------- 
(defun pertolinecz (cp p1 p2 / norm) 
  (setq norm (mapcar '- p2 p1) 
    p1 (trans p1 0 norm) 
    cp (trans cp 0 norm) 
  ) 
  (trans (list (car p1) (cadr p1) (caddr cp)) norm 0) 
) 
;-------生成一条line  ----（一级)------------------------ 
;;参数：pt1:起点，pt2:终点,均为三维点,即(x y z) 
(defun makeline (pt1 pt2) 
  (entmakex (list 
    '(0 . "line") 
    (cons 10 pt1) 
    (cons 11 pt2)) 
  ) 
) 
;;两点求四点矩形表:(左下 右下 右上 左上)------(一级)----------- 
(defun format2pt (pt1 pt2 / x1 x2 xx y1 y2 yy) 
  (setq x1 (car pt1)) 
  (setq x2 (car pt2)) 
  (setq y1 (cadr pt1)) 
  (setq y2 (cadr pt2)) 
  (if (< x2 x1) 
    (progn 
      (setq xx x1) 
      (setq x1 x2) 
      (setq x2 xx) 
    ) 
  ) 
  (if (< y2 y1) 
    (progn 
      (setq yy y1) 
      (setq y1 y2) 
      (setq y2 yy) 
    ) 
  ) 
  (list (list x1 y1) (list x2 y1) (list x2 y2) (list x1 y2)) 
) 
 
;点表生成多段线--------(一级)---------------- 
;线宽=nil，线宽为0  ;是否闭合=nil，不闭合 ;图层=nil，为当前图层 ;颜色=nil，为当前图层颜色  ;线型比例=nil，为1 
;(slch:lwpolyline 点表 是否闭合 线宽 图层 颜色 线型比例) 
;(slch:lwpolyline (list (1 2) (2 3)) T 2 "中心线" 6 5) 
(defun slch:lwpolyline (lst dxf70 plwid lay lwplcol lwplbili) 
  (entmake 
    (append 
      (list 
        '(0 . "LWPOLYLINE")    ;多段线 
        '(100 . "AcDbEntity") 
        '(100 . "AcDbPolyline") 
        (cons 90 (length lst)) ;点表 
        (if (= dxf70 T) 
          (cons 70 1)          ;是否闭合 
          (cons 70 0) 
        ) 
        (if plwid 
          (cons 43 plwid)      ;线宽 
          (cons 43 0) 
        ) 
        (if lay 
          (cons 8 lay)         ;图层 
          (cons 8 (getvar "clayer")) 
        ) 
        (if lwplcol 
          (cons 62 lwplcol)    ;颜色 
          (cons 62 256) 
        ) 
        (if lwplbili 
          (cons 48 lwplbili)   ;线型比例 
          (cons 48 (* 0.01 (getvar "DIMLFAC"))) 
        ) 
      ) 
      (mapcar '(lambda (pt) (cons 10 pt)) lst) 
    ) 
  ) 
)

飞雪神光 · 发表于 2024-5-9 18:26

本帖最后由飞雪神光于 2024-5-9 18:27 编辑

不要把函数和变量放在外面

huxu823 · 发表于 2024-5-9 20:40

飞雪神光发表于 2024-5-9 18:26
不要把函数和变量放在外面

感谢大神出手帮忙，

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

[源码] 请高手帮忙修改下源码，素土夯实！

本帖子中包含更多资源

点评

本帖子中包含更多资源