填充的两个函数
[*];;闭合实体区域填充----(一级)----
[*];;tcm 填充图案名 tcl 图层 tcj 角度 tcb 比例 col颜色
[*];;(sl:nam-hatch nam "钢筋混凝土" "PUB_HATCH" nil nil nil) 6参数
[*](defun sl:nam-hatch (nam tcm tcl tcj tcb col / ms ha obj)
[*](if (= tcl nil) (setq tcl (dxf1 nam 8)))
[*](if (= tcb nil) (setq tcb (sltcbl nam tcm tcm)))
[*](if (= col nil) (setq col (vla-get-color (vla-item *LAYS* tcl))))
[*](if (= tcj nil) (setq tcj 0))
[*](if (vl-catch-all-error-p
[*] (vl-catch-all-apply
[*] (function
[*] (lambda ()
[*] (if (= 1 (vlax-get-Property *AcDocument* 'ActiveSpace)) ;模型1,布局0
[*] (setq ms *Model-Space*)
[*] (setq ms *Paper-Space*)
[*] )
[*] (setq ha (vla-addhatch ms acHatchPatternTypePredefined tcm :vlax-false))
[*] (vla-appendouterloop ha (vlax-safearray-fill (vlax-make-safearray vlax-vbobject '(0 . 0)) (list (en2obj nam))))
[*] (vla-evaluate ha)
[*] (setq obj (en2obj (entlast)))
[*] (if tcj (vlax-put obj 'PatternAngle tcj))
[*] (vla-put-patternscale obj tcb)
[*] (vla-put-layer obj tcl)
[*] (vla-put-color obj col)
[*] )
[*] )
[*] )
[*] )
[*] (vl-catch-all-apply 'creathatch (list tcm (gps->lst-delsame (getpt (ssadd nam))) tcl tcj tcb col))
[*])
[*])
[*];点表创建填充----(一级)-------
[*];(creathatch "图案名"点表图层nil角度nil比例nil颜色nil)
[*](defun creathatch (tcm plis tcl tcj tcb tcc / edata nam)
[*](if (not tcl) (setq tcl (getvar "CLAYER")))
[*](if (not tcc) (setq tcc (vla-get-color (vla-item *LAYS* tcl))))
[*](if (not tcj) (setq tcj 0))
[*](if (not tcb) (setq tcb (sltcbl plis tcm tcm)))
[*](setq edata
[*] (append
[*] '((0 . "HATCH") (100 . "AcDbEntity") (67 . 0) )
[*] (list
[*] (cons 410 (getvar "ctab"))
[*] (cons 8 tcl) ;图层
[*] (cons 62 tcc) ;;颜色
[*] (cons 52 tcj) ;角度
[*] (cons 41 tcb);填充图案比例或间距(仅限图案填充)
[*] )
[*] '((100 . "AcDbHatch") (10 0.0 0.0 0.0) (210 0.0 0.0 1.0))
[*] (list (cons 2 tcm) ;图案名
[*] '(70 . 1) '(71 . 0) '(91 . 1)'(92 . 7) '(72 . 0) '(73 . 1)
[*] (cons 93 (length plis));点表
[*] )
[*] (mapcar '(lambda (e) (cons 10 e)) (mapcar '(lambda (e) (trans e 1 0)) plis))
[*] '((97 . 0) (75 . 0) (76 . 1)(47 . 174.807) (98 . 1) (10 0.0 0.0 0.0))
[*] )
[*])
[*](if (entmake edata)
[*] (progn
[*] (setq nam (entlast))
[*] (vla-put-patternscale (en2obj nam) tcb)
[*] )
[*])
[*]nam
[*])
通过网盘分享的文件：SLdesign V.0 (三领设计)链接: https://pan.baidu.com/s/10ArEBRIehGPUxdccAEPWLw?pwd=hck9 提取码: hck9
好函数，谢谢分享。 不错，完美的原来，sltcbl 函数没 本帖最后由 尘缘一生 于 2025-1-15 17:25 编辑
bai2000 发表于 2025-1-15 16:06
不错，完美的原来，sltcbl 函数没
关于这个函数，就是在没有给出比例时候，如何设置比例，但这个问题，虽然我一直在关注，却不能100%把握对，暂时那么用的。函数追求下去，特别三领集成，会难以穷尽。
;;设置填充比例 tcbl --------(一级)----
;;bjname 点表-实体-选择集hpat *.pat文件名 hname 图案文件名
(defun sltcbl (bjname hpat hname / ptlis dis tcbl)
(setq ptlis (slget-box bjname))
(setq dis (* 0.13 (distance (car ptlis) (cadr ptlis))))
(setq tcbl (fix (/ dis (dishname hpat hname))))
(if (not tcbl) (setq tcbl 10))
tcbl
)
;;读取填充文件patfile（全路径），hname图案定义的第二行---(一级)-----
(defun tcxsecon (patfile hname / ret str 1st str1)
(setq ret t)
(while (and ret (setq str (read-line patfile))) ;读填充文件
(setq 1st (substr str 1 1)) ;每一行的第一个字母
(if (and (= 1st "*") (wcmatch str (strcat "*" hname "*"))) ;如果是图案名字行 ,且是当前填充图案名
(setq str1 (read-line patfile) ret nil) ;读下面一行
)
)
str1
)
;;取*.pathname 线簇的距离-------(一级)---------
;;hpat *.pat文件名 hname 图案文件名
;;例 (dishname "acad.pat" "SWAMP")
(defun dishname (hpat hname / patfile measure str1 delta-y)
(if (/= (setq patfile (open (strcat sl-path0 "\\hatch\\" hpat ".pat") "r")) nil)
(setq str1 (tcxsecon patfile hname))
(if (/= (setq patfile (open (strcat sl-path0 "\\acadiso.pat") "r")) nil) ;填充的公制与英制
(if (= (setq str1 (tcxsecon patfile hname)) nil)
(progn
(setq patfile (open (strcat sl-path0 "\\acad.pat") "r"))
(setq str1 (tcxsecon patfile hname))
)
)
)
)
(close patfile)
(if str1
(progn
(setq delta-y (abs (atof (nth 4 (str->lst str1 ","))))) ;第5个值为线簇的距离
(if (or (= delta-y 0) (= delta-y nil))
(setq delta-y (* 20.0 slbl))
)
)
(setq delta-y (* 20.0 slbl))
)
delta-y
)
页:
[1]