填充的两个函数

尘缘一生

• ;;闭合实体区域填充----(一级)----
• ;;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

hubeiwdlue

好函数，谢谢分享。

bai2000

不错，完美的原来，sltcbl 函数没

尘缘一生

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
)
;;取*.pat  hname 线簇的距离-------(一级)---------
;;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
)