1 ;;;CADALYST 10/05 Tip 2065: HatchMaker.lsp	Hatch Maker	(c) 2005 Larry Schiele
   2 
   3 ;;;* ======   B E G I N   C O D E   N O W    ======   
   4 ;;;* HatchMaker.lsp written by Lanny Schiele at TMI Systems Design Corporation
   5 ;;;* Lanny.Schiele@tmisystems.com
   6 ;;;* Tested on AutoCAD 2002 & 2006. -- does include a 'VL' function -- should work on Acad2000 on up.
   7  
   8 (defun C:DrawHatch (/)
   9   (command "undo" "be")
  10   (setq os (getvar "OSMODE"))
  11   (setvar "OSMODE" 0)
  12   (command "UCS" "w")
  13   (command "PLINE" "0,0" "0,1" "1,1" "1,0" "c")
  14   (command "zoom" "c" "0.5,0.5" 1.1)
  15   (setvar "OSMODE" os)
  16   (setvar "SNAPMODE" 1)
  17   (setvar "SNAPUNIT" (list 0.01 0.01))
  18   (command "undo" "e")
  19   (alert
  20     "Draw pattern within 1x1 box using LINE or POINT entities only..."
  21   )
  22   (princ)
  23 )
  24  
  25 (defun C:SaveHatch (/      round    dxf      ListToFile
  26       user     SelSet   SelSetSize ssNth
  27       Ent      EntInfo  EntType  pt1 pt2
  28       Dist     AngTo    AngFrom  XDir YDir
  29       Gap      DeltaX   DeltaY   AngZone Counter
  30       Ratio    Factor   HatchName  HatchDescr
  31       FileLines       FileLines  FileName
  32       Scaler   ScaledX  ScaledY  RF x
  33       y      h       _AB      _BC _AC
  34       _AD      _DE      _EF      _EH _FH
  35       DimZin
  36      )
  37 ;;;* BEGIN NESTED FUNCTIONS
  38  
  39   (defun round (num)
  40     (if (>= (- num (fix num)) 0.5)
  41       (fix (1+ num))
  42       (fix num)
  43     )
  44   )
  45  
  46   (defun dxf (code EnameOrElist / VarType)
  47     (setq VarType (type EnameOrElist))
  48     (if (= VarType (read "ENAME"))
  49       (cdr (assoc code (entget EnameOrElist)))
  50       (cdr (assoc code EnameOrElist))
  51     )
  52   )
  53  
  54 
  55   (defun ListToFile (TextList    FileName  DoOpenWithNotepad
  56        AsAppend    /   TextItem
  57        File    RetVal
  58       )
  59     (if (setq File (open FileName
  60     (if AsAppend
  61       "a"
  62       "w"
  63     )
  64      )
  65  )
  66       (progn
  67  (foreach TextItem TextList
  68    (write-line TextItem File)
  69  )
  70  (setq File (close File))
  71  (if DoOpenWithNotepad
  72    (startapp "notepad" FileName)
  73  )
  74       )
  75     )
  76     (FindFile FileName)
  77   )
  78  
  79 ;;;* END NESTED FUNCTIONS
  80   
  81   (princ
  82     (strcat
  83       "\n."
  84       "\n    0,1 ----------- 1,1"
  85       "\n     |               | "
  86       "\n     |  Lines and    | "
  87       "\n     |  points must  | "
  88       "\n     |  be snapped   | "
  89       "\n     |  to nearest   | "
  90       "\n     |  0.01         | "
  91       "\n     |               | "
  92       "\n    0,0 ----------- 1,0"
  93       "\n."
  94       "\nNote:  Lines must be drawn within 0,0 to 1,1 and lie on a 0.01 grid."
  95      )
  96   )
  97   (textscr)
  98   (getstring "\nHit [ENTER] to continue...")
  99  
 100   (princ
 101     "\nSelect 1x1 pattern of lines and/or points for new hatch pattern..."
 102   )
 103   (while (not (setq SelSet (ssget (list (cons 0 "LINE,POINT")))))
 104   )
 105   (setq ssNth    0
 106  SelSetSize (sslength SelSet)
 107  DimZin    (getvar "DIMZIN")
 108   )
 109   (setvar "DIMZIN" 11)
 110   (if (> SelSetSize 0)
 111     (princ "\nAnalyaing entities...")
 112   )
 113   (while (< ssNth SelSetSize)
 114     (setq Ent   (ssname SelSet ssNth)
 115    EntInfo (entget Ent)
 116    EntType (dxf 0 EntInfo)
 117    ssNth   (+ ssNth 1)
 118     )
 119     (cond
 120       ((= EntType "POINT")
 121        (setq pt1      (dxf 10 EntInfo)
 122       FileLine (strcat "0,"
 123          (rtos (car pt1) 2 6)
 124          ","
 125          (rtos (cadr pt1) 2 6)
 126          ",0,1,0,-1"
 127         )
 128        )
 129        (princ (strcat "\n" FileLine))
 130        (setq FileLines (cons FileLine FileLines))
 131       )
 132       ((= EntType "LINE")
 133        (setq pt1     (dxf 10 EntInfo)
 134       pt2     (dxf 11 EntInfo)
 135       Dist    (distance pt1 pt2)
 136       AngTo   (angle pt1 pt2)
 137       AngFrom (angle pt2 pt1)
 138       IsValid nil
 139        )
 140        (if
 141   (or (equal (car pt1) (car pt2) 0.0001)
 142       (equal (cadr pt1) (cadr pt2) 0.0001)
 143   )
 144    (setq DeltaX 0
 145   DeltaY 1
 146   Gap (- Dist 1)
 147   IsValid T
 148    )
 149    (progn
 150      (setq Ang   (if (< AngTo pi)
 151        AngTo
 152        AngFrom
 153      )
 154     AngZone (fix (/ Ang (/ pi 4)))
 155     XDir   (abs (- (car pt2) (car pt1)))
 156     YDir   (abs (- (cadr pt2) (cadr pt1)))
 157     Factor  1
 158     RF   1
 159      )
 160      (cond
 161        ((= AngZone 0)
 162         (setq DeltaY (abs (sin Ang))
 163        DeltaX (abs (- (abs (/ 1.0 (sin Ang))) (abs (cos Ang)))
 164        )
 165         )
 166        )
 167        ((= AngZone 1)
 168         (setq DeltaY (abs (cos Ang))
 169        DeltaX (abs (sin Ang))
 170         )
 171        )
 172        ((= AngZone 2)
 173         (setq DeltaY (abs (cos Ang))
 174        DeltaX (abs (- (abs (/ 1.0 (cos Ang))) (abs (sin Ang)))
 175        )
 176         )
 177        )
 178        ((= AngZone 3)
 179         (setq DeltaY (abs (sin Ang))
 180        DeltaX (abs (cos Ang))
 181         )
 182        )
 183      )
 184      (if (not (equal XDir YDir 0.001))
 185        (progn
 186   (setq Ratio  (if (< XDir YDir)
 187           (/ YDir XDir)
 188           (/ XDir YDir)
 189         )
 190         RF     (* Ratio Factor)
 191         Scaler (/ 1
 192     (if (< XDir YDir)
 193       XDir
 194       YDir
 195     )
 196         )
 197   )
 198   (if (not (equal Ratio (round Ratio) 0.001))
 199     (progn
 200       (while
 201         (and
 202    (<= Factor 100)
 203    (not (equal RF (round RF) 0.001))
 204         )
 205          (setq Factor (+ Factor 1)
 206         RF     (* Ratio Factor)
 207          )
 208       )
 209       (if (and (> Factor 1) (<= Factor 100))
 210         (progn
 211    (setq _AB (* XDir Scaler Factor)
 212          _BC (* YDir Scaler Factor)
 213          _AC (sqrt (+ (* _AB _AB) (* _BC _BC)))
 214          _EF 1
 215          x   1
 216    )
 217    (while (< x (- _AB 0.5))
 218      (setq y (* x (/ YDir XDir))
 219     h (if (< Ang (/ pi 2))
 220         (- (+ 1 (fix y)) y)
 221         (- y (fix y))
 222       )
 223      )
 224      (if (< h _EF)
 225        (setq _AD x
 226       _DE y
 227       _AE (sqrt (+ (* x x) (* y y)))
 228       _EF h
 229        )
 230      )
 231      (setq x (+ x 1))
 232    )
 233    (if (< _EF 1)
 234      (setq _EH (/ (* _BC _EF) _AC)
 235     _FH (/ (* _AB _EF) _AC)
 236     DeltaX (+ _AE
 237         (if (> Ang (/ pi 2))
 238           (- _EH)
 239           _EH
 240         )
 241      )
 242     DeltaY (+ _FH)
 243     Gap (- Dist _AC)
 244     IsValid T
 245      )
 246    )
 247         )
 248       )
 249     )
 250   )
 251        )
 252      )
 253      (if (= Factor 1)
 254        (setq Gap     (- Dist (abs (* Factor (/ 1 DeltaY))))
 255       IsValid T
 256        )
 257      )
 258    )
 259        )
 260        (if
 261   IsValid
 262    (progn
 263      (setq FileLine
 264      (strcat
 265        (angtos AngTo 0 6)
 266        ","
 267        (rtos (car pt1) 2 8)
 268        ","
 269        (rtos (cadr pt1) 2 8)
 270        ","
 271        (rtos DeltaX 2 8)
 272        ","
 273        (rtos DeltaY 2 8)
 274        ","
 275        (rtos Dist 2 8)
 276        ","
 277        (rtos Gap 2 8)
 278      )
 279      )
 280      (princ (strcat "\n" FileLine))
 281      (setq FileLines (cons FileLine FileLines))
 282    )
 283    (princ (strcat "\n * * *  Line with invalid angle "
 284     (angtos AngTo 0 6)
 285     (chr 186)
 286     " omitted.  * * *"
 287    )
 288    )
 289        )
 290       )
 291       ((princ
 292   (strcat "\n * * *  Invalid entity " EntType " omitted.")
 293        )
 294       )
 295     )
 296   )
 297   (setvar "DIMZIN" DimZin)
 298   (if
 299     (and
 300       FileLines
 301       (setq HatchDescr
 302       (getstring T
 303    "\nBriefly describe this hatch pattern: "
 304       )
 305       )
 306       (setq FileName (getfiled "Hatch Pattern File"
 307           "I:\\Acad\\Hatch\\"
 308           "pat"
 309           1
 310        )
 311       )
 312     )
 313      (progn
 314        (if (= HatchDescr "")
 315   (setq HatchDescr "Custom hatch pattern")
 316        )
 317        (setq HatchName (vl-filename-base FileName)
 318       FileLines (cons (strcat "*" HatchName "," HatchDescr)
 319         (reverse FileLines)
 320          )
 321        )
 322        (princ
 323   "\n============================================================"
 324        )
 325        (princ
 326   (strcat "\nPlease wait while the hatch file is created...\n"
 327   )
 328        )
 329        (ListToFile FileLines FileName nil nil)
 330        (command "delay" 1500)  ;delay required so file can be created and found (silly, but req.)
 331        (if (findfile FileName)
 332   (progn
 333     (setvar "HPNAME" HatchName)
 334     (princ (strcat "\nHatch pattern '"
 335      HatchName
 336      "' is ready to use!"
 337     )
 338     )
 339   )
 340   (progn
 341     (princ "\nUnable to create hatch pattern file:")
 342     (princ (strcat "\n  " FileName))
 343   )
 344        )
 345      )
 346      (princ
 347        (if FileLines
 348   "\nCancelled."
 349   "\nUnable to create hatch pattern from selected entities."
 350        )
 351      )
 352   )
 353   (princ)
 354 )
 355  
 356 (princ "\n ************************************************************** ")
 357 (princ "\n**                                                            **")
 358 (princ "\n*  HatchMaker.lsp written by Lanny Schiele -- enjoy!           *")
 359 (princ "\n*                                                              *")
 360 (princ "\n*  Type in DRAWHATCH to have the environment created to draw.  *")
 361 (princ "\n*  Type in SAVEHATCH to save the pattern you created.          *")
 362 (princ "\n**                                                            **")
 363 (princ "\n ************************************************************** ")
 364 (princ)