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