国外大师的自定义填充制作源码

狂奔的大猫 · 发表于 2024-6-24 22:10:52

;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp Hatch Maker (c) 2005 Larry Schiele
;;;* ====== B E G I N C O D E N O W ======
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
;;;* Lanny.Schiele@tmisystems.com
;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.
(defun C:DrawHatch (/)
(command "undo" "be")
(setq os (getvar "OSMODE"))
(setvar "OSMODE" 0)
(command "UCS" "w")
(command "PLINE" "0,0" "0,1" "1,1" "1,0" "c")
(command "zoom" "c" "0.5,0.5" 1.1)
(setvar "OSMODE" os)
(setvar "SNAPMODE" 1)
(setvar "SNAPUNIT" (list 0.01 0.01))
(command "undo" "e")
(alert
"Draw pattern within 1x1 box using LINE or POINT entities only..."
)
(princ)
)
(defun C:SaveHatch (/ round dxf ListToFile
user SelSet SelSetSize ssNth
Ent EntInfo EntType pt1 pt2
Dist AngTo AngFrom XDir YDir
Gap DeltaX DeltaY AngZone Counter
Ratio Factor HatchName HatchDescr
FileLines FileLines FileName
Scaler ScaledX ScaledY RF x
y h _AB _BC _AC
_AD _DE _EF _EH _FH
DimZin
)
;;;* BEGIN NESTED FUNCTIONS
(defun round (num)
(if (>= (- num (fix num)) 0.5)
(fix (1+ num))
(fix num)
)
)
(defun dxf (code EnameOrElist / VarType)
(setq VarType (type EnameOrElist))
(if (= VarType (read "ENAME"))
(cdr (assoc code (entget EnameOrElist)))
(cdr (assoc code EnameOrElist))
)
)
(defun ListToFile (TextList FileName DoOpenWithNotepad
AsAppend / TextItem
File RetVal
)
(if (setq File (open FileName
(if AsAppend
"a"
"w"
)
)
)
(progn
(foreach TextItem TextList
(write-line TextItem File)
)
(setq File (close File))
(if DoOpenWithNotepad
(startapp "notepad" FileName)
)
)
)
(FindFile FileName)
)
;;;* END NESTED FUNCTIONS
(princ
(strcat
"\n."
"\n 0,1 ----------- 1,1"
"\n | | "
"\n | Lines and | "
"\n | points must | "
"\n | be snapped | "
"\n | to nearest | "
"\n | 0.01 | "
"\n | | "
"\n 0,0 ----------- 1,0"
"\n."
"\nNote: Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid."
)
)
(textscr)
(getstring "\nHit [ENTER] to continue...")
(princ
"\nSelect 1x1 pattern of lines and/or points for new hatch pattern..."
)
(while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))
)
(setq ssNth 0
SelSetSize (sslength SelSet)
DimZin (getvar "DIMZIN")
)
(setvar "DIMZIN" 11)
(if (> SelSetSize 0)
(princ "\nAnalyaing entities...")
)
(while (< ssNth SelSetSize)
(setq Ent (ssname SelSet ssNth)
EntInfo (entget Ent)
EntType (dxf 0 EntInfo)
ssNth (+ ssNth 1)
)
(cond
((= EntType "POINT")
(setq pt1 (dxf 10 EntInfo)
FileLine (strcat "0,"
(rtos (car pt1) 2 6)
","
(rtos (cadr pt1) 2 6)
",0,1,0,-1"
)
)
(princ (strcat "\n" FileLine))
(setq FileLines (cons FileLine FileLines))
)
((= EntType "LINE")
(setq pt1 (dxf 10 EntInfo)
pt2 (dxf 11 EntInfo)
Dist (distance pt1 pt2)
AngTo (angle pt1 pt2)
AngFrom (angle pt2 pt1)
IsValid nil
)
(if
(or (equal (car pt1) (car pt2) 0.0001)
(equal (cadr pt1) (cadr pt2) 0.0001)
)
(setq DeltaX 0
DeltaY 1
Gap (- Dist 1)
IsValid T
)
(progn
(setq Ang (if (< AngTo pi)
AngTo
AngFrom
)
AngZone (fix (/ Ang (/ pi 4)))
XDir (abs (- (car pt2) (car pt1)))
YDir (abs (- (cadr pt2) (cadr pt1)))
Factor 1
RF 1
)
(cond
((= AngZone 0)
(setq DeltaY (abs (sin Ang))
DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))
)
)
)
((= AngZone 1)
(setq DeltaY (abs (cos Ang))
DeltaX (abs (sin Ang))
)
)
((= AngZone 2)
(setq DeltaY (abs (cos Ang))
DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))
)
)
)
((= AngZone 3)
(setq DeltaY (abs (sin Ang))
DeltaX (abs (cos Ang))
)
)
)
(if (not (equal XDir YDir 0.001))
(progn
(setq Ratio (if (< XDir YDir)
(/ YDir XDir)
(/ XDir YDir)
)
RF (* Ratio Factor)
Scaler (/ 1
(if (< XDir YDir)
XDir
YDir
)
)
)
(if (not (equal Ratio (round Ratio) 0.001))
(progn
(while
(and
(<= Factor 100)
(not (equal RF (round RF) 0.001))
)
(setq Factor (+ Factor 1)
RF (* Ratio Factor)
)
)
(if (and (> Factor 1) (<= Factor 100))
(progn
(setq _AB (* XDir Scaler Factor)
_BC (* YDir Scaler Factor)
_AC (sqrt (+ (* _AB _AB) (* _BC _BC)))
_EF 1
x 1
)
(while (< x (- _AB 0.5))
(setq y (* x (/ YDir XDir))
h (if (< Ang (/ pi 2))
(- (+ 1 (fix y)) y)
(- y (fix y))
)
)
(if (< h _EF)
(setq _AD x
_DE y
_AE (sqrt (+ (* x x) (* y y)))
_EF h
)
)
(setq x (+ x 1))
)
(if (< _EF 1)
(setq _EH (/ (* _BC _EF) _AC)
_FH (/ (* _AB _EF) _AC)
DeltaX (+ _AE
(if (> Ang (/ pi 2))
(- _EH)
_EH
)
)
DeltaY (+ _FH)
Gap (- Dist _AC)
IsValid T
)
)
)
)
)
)
)
)
(if (= Factor 1)
(setq Gap (- Dist (abs (* Factor (/ 1 DeltaY))))
IsValid T
)
)
)
)
(if
IsValid
(progn
(setq FileLine
(strcat
(angtos AngTo 0 6)
","
(rtos (car pt1) 2 8)
","
(rtos (cadr pt1) 2 8)
","
(rtos DeltaX 2 8)
","
(rtos DeltaY 2 8)
","
(rtos Dist 2 8)
","
(rtos Gap 2 8)
)
)
(princ (strcat "\n" FileLine))
(setq FileLines (cons FileLine FileLines))
)
(princ (strcat "\n * * * Line with invalid angle "
(angtos AngTo 0 6)
(chr 186)
" omitted. * * *"
)
)
)
)
((princ
(strcat "\n * * * Invalid entity " EntType " omitted.")
)
)
)
)
(setvar "DIMZIN" DimZin)
(if
(and
FileLines
(setq HatchDescr
(getstring T
"\nBriefly describe this hatch pattern: "
)
)
(setq FileName (getfiled "Hatch Pattern File"
"I:\\Acad\\Hatch\"
"pat"
1
)
)
)
(progn
(if (= HatchDescr "")
(setq HatchDescr "Custom hatch pattern")
)
(setq HatchName (vl-filename-base FileName)
FileLines (cons (strcat "*" HatchName "," HatchDescr)
(reverse FileLines)
)
)
(princ
"\n============================================================"
)
(princ
(strcat "\nPlease wait while the hatch file is created...\n"
)
)
(ListToFile FileLines FileName nil nil)
(command "delay" 1500) ;delay required so file can be created and found (silly, but req.)
(if (findfile FileName)
(progn
(setvar "HPNAME" HatchName)
(princ (strcat "\nHatch pattern '"
HatchName
"' is ready to use!"
)
)
)
(progn
(princ "\nUnable to create hatch pattern file:")
(princ (strcat "\n " FileName))
)
)
)
(princ
(if FileLines
"\nCancelled."
"\nUnable to create hatch pattern from selected entities."
)
)
)
(princ)
)
(princ "\n ************************************************************** ")
(princ "\n** **")
(princ "\n* HatchMaker.lsp written by Lanny Schiele -- enjoy! *")
(princ "\n* *")
(princ "\n* Type in DRAWHATCH to have the environment created to draw. *")
(princ "\n* Type in SAVEHATCH to save the pattern you created. *")
(princ "\n** **")
(princ "\n ************************************************************** ")
(princ)

;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp  Hatch Maker  (c) 2005 Larry Schiele 
 
 
 
;;;* ======   B E G I N   C O D E   N O W    ======    
 
;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation 
 
;;;* Lanny.Schiele@tmisystems.com 
 
;;;* Tested on <a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a> 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up. 
 
 
 
(defun C:DrawHatch (/) 
 
  (command "undo" "be") 
 
  (setq os (getvar "OSMODE")) 
 
  (setvar "OSMODE" 0) 
 
  (command "UCS" "w") 
 
  (command "PLINE" "0,0" "0,1" "1,1" "1,0" "c") 
 
  (command "zoom" "c" "0.5,0.5" 1.1) 
 
  (setvar "OSMODE" os) 
 
  (setvar "SNAPMODE" 1) 
 
  (setvar "SNAPUNIT" (list 0.01 0.01)) 
 
  (command "undo" "e") 
 
  (alert 
 
    "Draw pattern within 1x1 box using LINE or POINT entities only..." 
 
  ) 
 
  (princ) 
 
) 
 
 
 
(defun C:SaveHatch (/      round    dxf      ListToFile 
 
      user     SelSet   SelSetSize ssNth 
 
      Ent      EntInfo  EntType  pt1 pt2 
 
      Dist     AngTo    AngFrom  XDir YDir 
 
      Gap      DeltaX   DeltaY   AngZone Counter 
 
      Ratio    Factor   HatchName  HatchDescr 
 
      FileLines       FileLines  FileName 
 
      Scaler   ScaledX  ScaledY  RF x 
 
      y      h       _AB      _BC _AC 
 
      _AD      _DE      _EF      _EH _FH 
 
      DimZin 
 
     ) 
 
;;;* BEGIN NESTED FUNCTIONS 
 
 
 
  (defun round (num) 
 
    (if (>= (- num (fix num)) 0.5) 
 
      (fix (1+ num)) 
 
      (fix num) 
 
    ) 
 
  ) 
 
 
 
  (defun dxf (code EnameOrElist / VarType) 
 
    (setq VarType (type EnameOrElist)) 
 
    (if (= VarType (read "ENAME")) 
 
      (cdr (assoc code (entget EnameOrElist))) 
 
      (cdr (assoc code EnameOrElist)) 
 
    ) 
 
  ) 
 
 
 
 
 
  (defun ListToFile (TextList    FileName  DoOpenWithNotepad 
 
       AsAppend    /   TextItem 
 
       File    RetVal 
 
      ) 
 
    (if (setq File (open FileName 
 
    (if AsAppend 
 
      "a" 
 
      "w" 
 
    ) 
 
     ) 
 
 ) 
 
      (progn 
 
 (foreach TextItem TextList 
 
   (write-line TextItem File) 
 
 ) 
 
 (setq File (close File)) 
 
 (if DoOpenWithNotepad 
 
   (startapp "notepad" FileName) 
 
 ) 
 
      ) 
 
    ) 
 
    (FindFile FileName) 
 
  ) 
 
 
 
;;;* END NESTED FUNCTIONS 
 
   
 
  (princ 
 
    (strcat 
 
      "\n." 
 
      "\n    0,1 ----------- 1,1" 
 
      "\n     |               | " 
 
      "\n     |  Lines and    | " 
 
      "\n     |  points must  | " 
 
      "\n     |  be snapped   | " 
 
      "\n     |  to nearest   | " 
 
      "\n     |  0.01         | " 
 
      "\n     |               | " 
 
      "\n    0,0 ----------- 1,0" 
 
      "\n." 
 
      "\nNote:  Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid." 
 
     ) 
 
  ) 
 
  (textscr) 
 
  (getstring "\nHit [ENTER] to continue...") 
 
 
 
  (princ 
 
    "\nSelect 1x1 pattern of lines and/or points for new hatch pattern..." 
 
  ) 
 
  (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT"))))) 
 
  ) 
 
  (setq ssNth    0 
 
 SelSetSize (sslength SelSet) 
 
 DimZin    (getvar "DIMZIN") 
 
  ) 
 
  (setvar "DIMZIN" 11) 
 
  (if (> SelSetSize 0) 
 
    (princ "\nAnalyaing entities...") 
 
  ) 
 
  (while (< ssNth SelSetSize) 
 
    (setq Ent   (ssname SelSet ssNth) 
 
   EntInfo (entget Ent) 
 
   EntType (dxf 0 EntInfo) 
 
   ssNth   (+ ssNth 1) 
 
    ) 
 
    (cond 
 
      ((= EntType "POINT") 
 
       (setq pt1      (dxf 10 EntInfo) 
 
      FileLine (strcat "0," 
 
         (rtos (car pt1) 2 6) 
 
         "," 
 
         (rtos (cadr pt1) 2 6) 
 
         ",0,1,0,-1" 
 
        ) 
 
       ) 
 
       (princ (strcat "\n" FileLine)) 
 
       (setq FileLines (cons FileLine FileLines)) 
 
      ) 
 
      ((= EntType "LINE") 
 
       (setq pt1     (dxf 10 EntInfo) 
 
      pt2     (dxf 11 EntInfo) 
 
      Dist    (distance pt1 pt2) 
 
      AngTo   (angle pt1 pt2) 
 
      AngFrom (angle pt2 pt1) 
 
      IsValid nil 
 
       ) 
 
       (if 
 
  (or (equal (car pt1) (car pt2) 0.0001) 
 
      (equal (cadr pt1) (cadr pt2) 0.0001) 
 
  ) 
 
   (setq DeltaX 0 
 
  DeltaY 1 
 
  Gap (- Dist 1) 
 
  IsValid T 
 
   ) 
 
   (progn 
 
     (setq Ang   (if (< AngTo pi) 
 
       AngTo 
 
       AngFrom 
 
     ) 
 
    AngZone (fix (/ Ang (/ pi 4))) 
 
    XDir   (abs (- (car pt2) (car pt1))) 
 
    YDir   (abs (- (cadr pt2) (cadr pt1))) 
 
    Factor  1 
 
    RF   1 
 
     ) 
 
     (cond 
 
       ((= AngZone 0) 
 
        (setq DeltaY (abs (sin Ang)) 
 
       DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang))) 
 
       ) 
 
        ) 
 
       ) 
 
       ((= AngZone 1) 
 
        (setq DeltaY (abs (cos Ang)) 
 
       DeltaX (abs (sin Ang)) 
 
        ) 
 
       ) 
 
       ((= AngZone 2) 
 
        (setq DeltaY (abs (cos Ang)) 
 
       DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang))) 
 
       ) 
 
        ) 
 
       ) 
 
       ((= AngZone 3) 
 
        (setq DeltaY (abs (sin Ang)) 
 
       DeltaX (abs (cos Ang)) 
 
        ) 
 
       ) 
 
     ) 
 
     (if (not (equal XDir YDir 0.001)) 
 
       (progn 
 
  (setq Ratio  (if (< XDir YDir) 
 
          (/ YDir XDir) 
 
          (/ XDir YDir) 
 
        ) 
 
        RF     (* Ratio Factor) 
 
        Scaler (/ 1 
 
    (if (< XDir YDir) 
 
      XDir 
 
      YDir 
 
    ) 
 
        ) 
 
  ) 
 
  (if (not (equal Ratio (round Ratio) 0.001)) 
 
    (progn 
 
      (while 
 
        (and 
 
   (<= Factor 100) 
 
   (not (equal RF (round RF) 0.001)) 
 
        ) 
 
         (setq Factor (+ Factor 1) 
 
        RF     (* Ratio Factor) 
 
         ) 
 
      ) 
 
      (if (and (> Factor 1) (<= Factor 100)) 
 
        (progn 
 
   (setq _AB (* XDir Scaler Factor) 
 
         _BC (* YDir Scaler Factor) 
 
         _AC (sqrt (+ (* _AB _AB) (* _BC _BC))) 
 
         _EF 1 
 
         x   1 
 
   ) 
 
   (while (< x (- _AB 0.5)) 
 
     (setq y (* x (/ YDir XDir)) 
 
    h (if (< Ang (/ pi 2)) 
 
        (- (+ 1 (fix y)) y) 
 
        (- y (fix y)) 
 
      ) 
 
     ) 
 
     (if (< h _EF) 
 
       (setq _AD x 
 
      _DE y 
 
      _AE (sqrt (+ (* x x) (* y y))) 
 
      _EF h 
 
       ) 
 
     ) 
 
     (setq x (+ x 1)) 
 
   ) 
 
   (if (< _EF 1) 
 
     (setq _EH (/ (* _BC _EF) _AC) 
 
    _FH (/ (* _AB _EF) _AC) 
 
    DeltaX (+ _AE 
 
        (if (> Ang (/ pi 2)) 
 
          (- _EH) 
 
          _EH 
 
        ) 
 
     ) 
 
    DeltaY (+ _FH) 
 
    Gap (- Dist _AC) 
 
    IsValid T 
 
     ) 
 
   ) 
 
        ) 
 
      ) 
 
    ) 
 
  ) 
 
       ) 
 
     ) 
 
     (if (= Factor 1) 
 
       (setq Gap     (- Dist (abs (* Factor (/ 1 DeltaY)))) 
 
      IsValid T 
 
       ) 
 
     ) 
 
   ) 
 
       ) 
 
       (if 
 
  IsValid 
 
   (progn 
 
     (setq FileLine 
 
     (strcat 
 
       (angtos AngTo 0 6) 
 
       "," 
 
       (rtos (car pt1) 2 8) 
 
       "," 
 
       (rtos (cadr pt1) 2 8) 
 
       "," 
 
       (rtos DeltaX 2 8) 
 
       "," 
 
       (rtos DeltaY 2 8) 
 
       "," 
 
       (rtos Dist 2 8) 
 
       "," 
 
       (rtos Gap 2 8) 
 
     ) 
 
     ) 
 
     (princ (strcat "\n" FileLine)) 
 
     (setq FileLines (cons FileLine FileLines)) 
 
   ) 
 
   (princ (strcat "\n * * *  Line with invalid angle " 
 
    (angtos AngTo 0 6) 
 
    (chr 186) 
 
    " omitted.  * * *" 
 
   ) 
 
   ) 
 
       ) 
 
      ) 
 
      ((princ 
 
  (strcat "\n * * *  Invalid entity " EntType " omitted.") 
 
       ) 
 
      ) 
 
    ) 
 
  ) 
 
  (setvar "DIMZIN" DimZin) 
 
  (if 
 
    (and 
 
      FileLines 
 
      (setq HatchDescr 
 
      (getstring T 
 
   "\nBriefly describe this hatch pattern: " 
 
      ) 
 
      ) 
 
      (setq FileName (getfiled "Hatch Pattern File" 
 
          "I:\\Acad\\Hatch\" 
 
          "pat" 
 
          1 
 
       ) 
 
      ) 
 
    ) 
 
     (progn 
 
       (if (= HatchDescr "") 
 
  (setq HatchDescr "Custom hatch pattern") 
 
       ) 
 
       (setq HatchName (vl-filename-base FileName) 
 
      FileLines (cons (strcat "*" HatchName "," HatchDescr) 
 
        (reverse FileLines) 
 
         ) 
 
       ) 
 
       (princ 
 
  "\n============================================================" 
 
       ) 
 
       (princ 
 
  (strcat "\nPlease wait while the hatch file is created...\n" 
 
  ) 
 
       ) 
 
       (ListToFile FileLines FileName nil nil) 
 
       (command "delay" 1500)  ;delay required so file can be created and found (silly, but req.) 
 
       (if (findfile FileName) 
 
  (progn 
 
    (setvar "HPNAME" HatchName) 
 
    (princ (strcat "\nHatch pattern '" 
 
     HatchName 
 
     "' is ready to use!" 
 
    ) 
 
    ) 
 
  ) 
 
  (progn 
 
    (princ "\nUnable to create hatch pattern file:") 
 
    (princ (strcat "\n  " FileName)) 
 
  ) 
 
       ) 
 
     ) 
 
     (princ 
 
       (if FileLines 
 
  "\nCancelled." 
 
  "\nUnable to create hatch pattern from selected entities." 
 
       ) 
 
     ) 
 
  ) 
 
  (princ) 
 
) 
 
 
 
(princ "\n ************************************************************** ") 
 
(princ "\n**                                                            **") 
 
(princ "\n*  HatchMaker.lsp written by Lanny Schiele -- enjoy!           *") 
 
(princ "\n*                                                              *") 
 
(princ "\n*  Type in DRAWHATCH to have the environment created to draw.  *") 
 
(princ "\n*  Type in SAVEHATCH to save the pattern you created.          *") 
 
(princ "\n**                                                            **") 
 
(princ "\n ************************************************************** ") 
 
(princ)

可惜只能在1X1的方格绘制，不能像源泉那样的根据X Y间距生成自定义填充，希望大神们优化！！！！

paulpipi · 发表于 2024-6-24 23:01:53

感谢分享，希望有高手改进

paulpipi · 发表于 2024-6-24 23:03:53

感谢分享，希望有高手改进

yk1216 · 发表于 2024-6-25 08:43:23

感谢分享，希望有高手改进

xiao1984 · 发表于 2024-6-25 09:16:55

英文的注释和说明看着不舒服！改成了中文

狂奔的大猫 · 发表于 2024-6-25 10:28:04

大家共同努力争取早日将填充制作源码化

kozmosovia · 发表于 2024-6-25 16:44:37

源泉的mkpat是免费的，还折腾重复造轮子有啥意义？写代码学习制作PAT的技术？学会了也没啥用武之地。

`中微子 · 发表于 2024-6-25 23:02:47

感谢源泉10多年陪伴!

960322 · 发表于 2024-6-26 02:27:03

kozmosovia 发表于 2024-6-25 16:44
源泉的mkpat是免费的，还折腾重复造轮子有啥意义？写代码学习制作PAT的技术？学会了也没啥用武之地。

有源码可以学习或则修改不是更好吗

guosheyang · 发表于 2024-6-28 09:19:55

关键是主轴垂直偏差与水平偏差的比值不能太小，否则不能填充

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

[源码] 国外大师的自定义填充制作源码

本帖子中包含更多资源

本帖子中包含更多资源