Dirt / Soil Hatch LISP

[RockyMarc]

G'day,

 

We have recently been taken over by a new company, we are now using AutoCAD 2009 before using AutoCAD 2006 with custom cad designed by a software guru, who is know not with us.

 

We use to have this great Dirt / Soil LISP that would follow a line with Nearest sticky and draw in the Dirt as a hatch (using Earth hatch) at any length you wanted, and also to scale (picture attached).

Now we have StrucPLUS AutoCAD package and it has a pretty ordinary Dirt / Soil Block which does scale but only comes as the Block size and you can't stretch it or anything unless you explode it (ugh lines!).

 

Just wondering if anyone out there has a Dirt / Soil LISP like I explained ?

Cheers!

[The Buzzard]

G'day,

 

We have recently been taken over by a new company, we are now using AutoCAD 2009 before using AutoCAD 2006 with custom cad designed by a software guru, who is know not with us.

 

We use to have this great Dirt / Soil LISP that would follow a line with Nearest sticky and draw in the Dirt as a hatch (using Earth hatch) at any length you wanted, and also to scale (picture attached).

Now we have StrucPLUS AutoCAD package and it has a pretty ordinary Dirt / Soil Block which does scale but only comes as the Block size and you can't stretch it or anything unless you explode it (ugh lines!).

 

Just wondering if anyone out there has a Dirt / Soil LISP like I explained ?

Cheers!

 

I am not exactly sure, But you are welcome to these. It could be in there. Please see attached.

aec20patterns.zip

[RockyMarc]

Hmm not really, they are just hatch patterns.

I was after a lisp that would invoke the Earth hatch pattern (standard one) at a certain scale & at 45deg. that would let me pick 2 points on a line and would plonk that hatch down.

[The Buzzard]

Sorry about that. Maybe something will come along.

[lpseifert]

Try making a block of the earth hatch (at the size/angle you would like to see it plotted); then drag it to a Toolpalette. In the properties of the new 'tool' you can have it inserted at an 'Auxiliary scale' (Dimscale, Plot scale) and also have it 'Prompt for rotation' (2 points).

[RockyMarc]

That only gives you a certain size of the block though ?

Like once you make it that size (as in length along the line) it is that same size everytime you insert it ?

 

I like to make them all different to give a not so perfect look about the drawings

[The Buzzard]

That only gives you a certain size of the block though ?

Like once you make it that size (as in length along the line) it is that same size everytime you insert it ?

 

I like to make them all different to give a not so perfect look about the drawings

 

Something I just threw together. May need some tweaking.

 

Earth.lsp

Type Earth to start.

 

;/////////////////////////////////////////////////////////////////////////////////////////
;
(defun C:EARTH (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 SCL WID ANG)
 (setq PRP "EARTH")
 (setq WID 12)
 (setq SCL 12)
 (setq ANG 0)
 (setq CL01 (getpoint "\nSpecify first point: ")
       CL02 (getpoint CL01 "\nSpecify second point: ")
       RAD# (angle CL01 CL02)
       DEG# (RTD RAD#)
       DLEN (distance CL01 CL02)
       CL01 (trans CL01 1 0)
       CL02 (trans CL02 1 0)
       PT01 CL01
       PT02 (polar PT01 (DTR (+ DEG#   0)) DLEN)
       PT03 (polar PT01 (DTR (+ DEG# 270)) WID)
       PT04 (polar PT02 (DTR (+ DEG# 270)) WID))
 (command "._pline" PT01 PT02 PT04 PT03 "C")
 (setq E01 (entlast))
 (command "._-bhatch" "_a" "_a" "_y" "" "_p" PRP SCL ANG "_s" "_l" "" "")
 (command "._erase" E01 "")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
(defun DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
(defun RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;///////////////////////////////////////////////////////////////////////////////////////// 

Edited July 27, 2010 by The Buzzard

[The Buzzard]

This one has more prompts to make it more flexible. Also added an error trap and layer function as well.

I commented areas in the code that you may want to change the values. Refer to the values highlighted in red.

If you need help with this , Then please mention.

 

EARTH.lsp

Type EARTH to start.

 

;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
(defun C:EARTH (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 CPS SUS)
 (setq SUS_LST (list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits" "clayer"))
 (setq SUS (mapcar 'getvar SUS_LST))
 (setq TERR *error*)
 (setq *error* EARTH_ET)
 (or H:PRP (setq H:PRP "[color=red]EARTH[/color]"))      ;[color=red]Default Hatch Pattern[/color]
 (or H:WID (setq H:WID [color=red]6[/color]))            ;[color=red]Default Hatch Width[/color]
 (or H:SCL (setq H:SCL [color=red]6[/color]))            ;[color=red]Default Hatch Scale[/color]
 (or H:ANG (setq H:ANG [color=red]45[/color]))           ;[color=red]Default Hatch Angle[/color]
 (setq H:WID
   (cond
     ((getint (strcat "\nSpecify hatch width. <"(rtos H:WID 2 0)">: ")))(T H:WID)))
 (setq H:SCL
   (cond
     ((getint (strcat "\nSpecify hatch scale. <"(rtos H:SCL 2 0)">: ")))(T H:SCL)))
 (setq H:ANG
   (cond
     ((getint (strcat "\nSpecify hatch angle. <"(rtos H:ANG 2 0)">: ")))(T H:ANG)))
 (setq CL01 (getpoint "\nSpecify first point: ")
       CL02 (getpoint CL01 "\nSpecify second point: ")
       RAD# (angle CL01 CL02)
       DEG# (EARTH_RTD RAD#)
       DLEN (distance CL01 CL02)
       CL01 (trans CL01 1 0)
       CL02 (trans CL02 1 0)
       PT01 CL01
       PT02 (polar PT01 (EARTH_DTR (+ DEG#   0)) DLEN)
       PT03 (polar PT01 (EARTH_DTR (+ DEG# 270)) H:WID)
       PT04 (polar PT02 (EARTH_DTR (+ DEG# 270)) H:WID))
 (EARTH_CPS)
 (EARTH_ML "[color=red]HATCH[/color]" [color=red]1[/color] "[color=red]Continuous[/color]" [color=red]18[/color]) ;[color=red]Set layer name, color, linetype, & lineweight[/color]
 (setvar "clayer" "[color=red]HATCH[/color]")            ;[color=red]Set HATCH layer current[/color]
 (command "._pline" PT01 PT02 PT04 PT03 "C")
 (setq E01 (entlast))
 (command "._-bhatch" "_a" "_a" "_y" "" "_p" H:PRP H:SCL H:ANG "_s" "_l" "" "")
 (command "._erase" E01 "")
 (EARTH_RUS)
 (princ))
(princ)
(princ "\nEARTH.lsp loaded... Type EARTH to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun EARTH_DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun EARTH_RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun EARTH_ML (LNAM LCLR LTYP LWGT)
 (if (null (tblsearch "layer" LNAM))
   (entmake
     (list
       (cons   0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons   2  LNAM)
       (cons  70  0)
       (cons  62  LCLR)
       (cons   6  LTYP)
       (cons 290  1)
       (cons 370  LWGT))))
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun EARTH_CPS ()
 (setq CPS (list 0 1 0 0 0 0))
 (mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
 (princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun EARTH_RUS ()
 (setq *error* TERR)
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has completed successfully and will now restore your settings.")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun EARTH_ET (ERRORMSG)
 (command nil nil nil)
 (if (not (member ERRORMSG '("console break" "Function cancelled")))
   (princ (strcat "\nError:" ERRORMSG)))
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has encountered a user error!")
 (princ "\nProgram will now restore your settings and exit.")
 (terpri)
 (setq *error* TERR)
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////

Edited July 28, 2010 by The Buzzard

[The Buzzard]

RockMarc,

 

Is this program working for you or not?

Enquiring minds would like to know.

[autolisp]

This one has more prompts to make it more flexible. Also added an error trap and layer function as well.

I commented areas in the code that you may want to change the values. Refer to the values highlighted in red.

If you need help with this , Then please mention.

 

EARTH.lsp

Type EARTH to start.

 

;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
(defun C:EARTH (/ CL01 CL02 RAD# DEG# PT01 PT02 PT03 PT04 DLEN E01 CPS SUS)
(setq SUS_LST (list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits" "clayer"))
(setq SUS (mapcar 'getvar SUS_LST))
(setq TERR *error*)
(setq *error* EARTH_ET)
(or H:PRP (setq H:PRP "[color=red]EARTH[/color]")) ;[color=red]Default Hatch Pattern[/color]
(or H:WID (setq H:WID [color=red]6[/color])) ;[color=red]Default Hatch Width[/color]
(or H:SCL (setq H:SCL [color=red]6[/color])) ;[color=red]Default Hatch Scale[/color]
(or H:ANG (setq H:ANG [color=red]45[/color])) ;[color=red]Default Hatch Angle[/color]
(setq H:WID
(cond
((getint (strcat "\nSpecify hatch width. <"(rtos H:WID 2 0)">: ")))(T H:WID)))
(setq H:SCL
(cond
((getint (strcat "\nSpecify hatch scale. <"(rtos H:SCL 2 0)">: ")))(T H:SCL)))
(setq H:ANG
(cond
((getint (strcat "\nSpecify hatch angle. <"(rtos H:ANG 2 0)">: ")))(T H:ANG)))
(setq CL01 (getpoint "\nSpecify first point: ")
CL02 (getpoint CL01 "\nSpecify second point: ")
RAD# (angle CL01 CL02)
DEG# (EARTH_RTD RAD#)
DLEN (distance CL01 CL02)
CL01 (trans CL01 1 0)
CL02 (trans CL02 1 0)
PT01 CL01
PT02 (polar PT01 (EARTH_DTR (+ DEG# 0)) DLEN)
PT03 (polar PT01 (EARTH_DTR (+ DEG# 270)) H:WID)
PT04 (polar PT02 (EARTH_DTR (+ DEG# 270)) H:WID))
(EARTH_CPS)
(EARTH_ML "[color=red]HATCH[/color]" [color=red]1[/color] "[color=red]Continuous[/color]" [color=red]18[/color]) ;[color=red]Set layer name, color, linetype, & lineweight[/color]
(setvar "clayer" "[color=red]HATCH[/color]") ;[color=red]Set HATCH layer current[/color]
(command "._pline" PT01 PT02 PT04 PT03 "C")
(setq E01 (entlast))
(command "._-bhatch" "_a" "_a" "_y" "" "_p" H:PRP H:SCL H:ANG "_s" "_l" "" "")
(command "._erase" E01 "")
(EARTH_RUS)
(princ))
(princ)
(princ "\nEARTH.lsp loaded... Type EARTH to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun EARTH_DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun EARTH_RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun EARTH_ML (LNAM LCLR LTYP LWGT)
(if (null (tblsearch "layer" LNAM))
(entmake
(list
(cons 0 "LAYER")
(cons 100 "AcDbSymbolTableRecord")
(cons 100 "AcDbLayerTableRecord")
(cons 2 LNAM)
(cons 70 0)
(cons 62 LCLR)
(cons 6 LTYP)
(cons 290 1)
(cons 370 LWGT))))
(princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun EARTH_CPS ()
(setq CPS (list 0 1 0 0 0 0))
(mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
(princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun EARTH_RUS ()
(setq *error* TERR)
(if SUS (mapcar 'setvar SUS_LST SUS))
(princ "\nEARTH.lsp has completed successfully and will now restore your settings.")
(princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun EARTH_ET (ERRORMSG)
(command nil nil nil)
(if (not (member ERRORMSG '("console break" "Function cancelled")))
(princ (strcat "\nError:" ERRORMSG)))
(if SUS (mapcar 'setvar SUS_LST SUS))
(princ "\nEARTH.lsp has encountered a user error!")
(princ "\nProgram will now restore your settings and exit.")
(terpri)
(setq *error* TERR)
(princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////

dear sir

very good lisp

thx for sharing

but one problem in lisp

im pick 1st point end & 2nd point nea hatch is genrete cross

[The Buzzard]

dear sir

very good lisp

thx for sharing

but one problem in lisp

im pick 1st point end & 2nd point nea hatch is genrete cross

 

 

Nothing wrong on my end, The code only creates an Earth hatch like the one below.

[autolisp]

Nothing wrong on my end, The code only create an Earth hatch like the one below.

Command: earth

Specify hatch width. : 50

Specify hatch scale. : 50

Specify hatch angle. :

Specify first point:

Specify second point: nea to

EARTH.lsp has completed successfully and will now restore your settings.

[The Buzzard]

[ATTACH]22111[/ATTACH]

Command: earth

Specify hatch width. : 50

Specify hatch scale. : 50

Specify hatch angle. :

Specify first point:

Specify second point: nea to

EARTH.lsp has completed successfully and will now restore your settings.

 

 

I just tested with the same values you were using and did not get a problem. I am not sure how you are getting that.

[The Buzzard]

Ok, I see whats going on now. You went from an extremely large hatch setting and switched back to a much smaller setting.

I am not sure what to do about that since it also happens when you manually run the hatch command. If the drawing is closed out

and then restarted, All seems to work again. Why you would want to go from one extreme to another is beyond me.

I hope I can find a fix for this, But when using, One should use a little common acad sense. Maybe entmake for the hatch would be

a better idea.

[The Buzzard]

Thanks for testing autolisp,

 

I think I have the issue resolved. I used entmake to create the hatch instead of a command call. There does not seem to be a problem now with changing scale from one extreme to another. Also note the code runs much faster.

 

Earth.lsp

 

;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
;
(defun C:EARTH (/ CL01 CL02 CPS DEG# DLEN E01 HANG HPRP HSCL HWID RAD# PT01 PT02 PT03 PT04 SUS)
 (setq SUS_LST (list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits" "clayer"))
 (setq SUS (mapcar 'getvar SUS_LST))
 (setq TERR *error*)
 (setq *error* EARTH_ET)
 (or H:PRP (setq H:PRP "EARTH"))      ;Default Hatch Pattern
 (or H:WID (setq H:WID 6))            ;Default Hatch Width
 (or H:SCL (setq H:SCL 6))            ;Default Hatch Scale
 (or H:ANG (setq H:ANG 45))           ;Default Hatch Angle
 (setq H:WID
   (cond
     ((getint (strcat "\nSpecify hatch width. <"(rtos H:WID 2 0)">: ")))(T H:WID)))
 (setq H:SCL
   (cond
     ((getint (strcat "\nSpecify hatch scale. <"(rtos H:SCL 2 0)">: ")))(T H:SCL)))
 (setq H:ANG
   (cond
     ((getint (strcat "\nSpecify hatch angle. <"(rtos H:ANG 2 0)">: ")))(T H:ANG)))
 (setq HPRP H:PRP
       HSCL H:SCL
       HWID H:WID
       HANG (EARTH_DTR H:ANG)
       CL01 (getpoint "\nSpecify first point: ")
       CL02 (getpoint CL01 "\nSpecify second point: ")
       RAD# (angle CL01 CL02)
       DEG# (EARTH_RTD RAD#)
       DLEN (distance CL01 CL02)
       CL01 (trans CL01 1 0)
       CL02 (trans CL02 1 0)
       PT01 CL01
       PT02 (polar PT01 (EARTH_DTR (+ DEG#   0)) DLEN)
       PT03 (polar PT01 (EARTH_DTR (+ DEG# 270)) HWID)
       PT04 (polar PT02 (EARTH_DTR (+ DEG# 270)) HWID))
 (EARTH_CPS)
 (EARTH_ML "HATCH" 1 "Continuous" 18) ;Set layer name, color, linetype, & lineweight
 (setvar "clayer" "HATCH")            ;Set HATCH layer current
 (entmake
   (list
     (cons 0   "LWPOLYLINE")
     (cons 100 "AcDbEntity")
     (cons 67   0)
     (cons 410 "Model")
     (cons 8   "0")
     (cons 100 "AcDbPolyline")
     (cons 90   4)
     (cons 70   1)
     (cons 43   0.0)
     (cons 38   0.0)
     (cons 39   0.0)
     (cons 10   PT01)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 10   PT02)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 10   PT04)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 10   PT03)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 210 (list 0.0 0.0 1.0))))
 (setq E01 (entlast))
 (entmake
   (list
     (cons 0   "HATCH")
     (cons 100 "AcDbEntity")
     (cons 67   0)
     (cons 410 "Model")
     (cons 8   "HATCH")
     (cons 100 "AcDbHatch")
     (cons 10  (list  0.0 0.0 0.0))
     (cons 210 (list  0.0 0.0 1.0))
     (cons 2    HPRP)
     (cons 70   0)
     (cons 71   0)
     (cons 91   1)
     (cons 92   1)
     (cons 93   4)
     (cons 72   1)
     (cons 10   PT01)
     (cons 11   PT02)
     (cons 72   1)
     (cons 10   PT02)
     (cons 11   PT04)
     (cons 72   1)
     (cons 10   PT04)
     (cons 11   PT03)
     (cons 72   1)
     (cons 10   PT03)
     (cons 11   PT01)
     (cons 97   0)
     (cons 75   0)
     (cons 76   1)
     (cons 52   HANG)
     (cons 41   HSCL)
     (cons 77   0)
     (cons 78   6)
     (cons 53   0.785398)
     (cons 43   0.0)
     (cons 44   0.0)
     (cons 45   2.22045e-016)
     (cons 46   2.12132)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   0.785398)
     (cons 43  -0.397748)
     (cons 44   0.397748)
     (cons 45   2.22045e-016)
     (cons 46   2.12132)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   0.785398)
     (cons 43  -0.795495)
     (cons 44   0.795495)
     (cons 45   2.22045e-016)
     (cons 46   2.12132)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   2.35619)
     (cons 43  -0.795495)
     (cons 44   1.06066)
     (cons 45  -2.12132)
     (cons 46   4.44089e-016)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   2.35619)
     (cons 43  -0.397748)
     (cons 44   1.45841)
     (cons 45  -2.12132)
     (cons 46   4.44089e-016)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   2.35619)
     (cons 43   1.11022e-016)
     (cons 44   1.85616)
     (cons 45  -2.12132)
     (cons 46   4.44089e-016)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 98   1)
     (cons 10  (list  0.0 0.0 0.0))))
 (command "._erase" E01 "")
 (setenv "MaxHatch" "100")
 (EARTH_RUS)
 (princ))
(princ)
(princ "\nEARTH.lsp loaded... Type EARTH to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun EARTH_DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun EARTH_RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun EARTH_ML (LNAM LCLR LTYP LWGT)
 (if (null (tblsearch "layer" LNAM))
   (entmake
     (list
       (cons   0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons   2  LNAM)
       (cons  70  0)
       (cons  62  LCLR)
       (cons   6  LTYP)
       (cons 290  1)
       (cons 370  LWGT))))
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun EARTH_CPS ()
 (setq CPS (list 0 1 0 0 0 0))
 (mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
 (princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun EARTH_RUS ()
 (setq *error* TERR)
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has completed successfully and will now restore your settings.")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun EARTH_ET (ERRORMSG)
 (command nil nil nil)
 (if (not (member ERRORMSG '("console break" "Function cancelled")))
   (princ (strcat "\nError:" ERRORMSG)))
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has encountered a user error!")
 (princ "\nProgram will now restore your settings and exit.")
 (terpri)
 (setq *error* TERR)
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////

Edited July 31, 2010 by The Buzzard

[The Buzzard]

All command calls are eliminated. This is an entmake code all the way. It seems that entmake is worth the trouble.

Please enjoy.

 

Earth.lsp

;/////////////////////////////////////////////////////////////////////////////////////////
;
; Main Function.
;
;
(defun C:EARTH (/ CL01 CL02 CPS DEG# DLEN E01 HANG HPRP HSCL HWID RAD# PT01 PT02 PT03 PT04 SUS)
 (setq SUS_LST (list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits" "clayer"))
 (setq SUS (mapcar 'getvar SUS_LST))
 (setq TERR *error*)
 (setq *error* EARTH_ET)
 (or H:PRP (setq H:PRP "EARTH"))      ;Default Hatch Pattern
 (or H:WID (setq H:WID 6))            ;Default Hatch Width
 (or H:SCL (setq H:SCL 6))            ;Default Hatch Scale
 (or H:ANG (setq H:ANG 45))           ;Default Hatch Angle
 (setq H:WID
   (cond
     ((getint (strcat "\nSpecify hatch width. <"(rtos H:WID 2 0)">: ")))(T H:WID)))
 (setq H:SCL
   (cond
     ((getint (strcat "\nSpecify hatch scale. <"(rtos H:SCL 2 0)">: ")))(T H:SCL)))
 (setq H:ANG
   (cond
     ((getint (strcat "\nSpecify hatch angle. <"(rtos H:ANG 2 0)">: ")))(T H:ANG)))
 (setq HPRP H:PRP
       HSCL H:SCL
       HWID H:WID
       HANG (EARTH_DTR H:ANG)
       CL01 (getpoint "\nSpecify first point: ")
       CL02 (getpoint CL01 "\nSpecify second point: ")
       RAD# (angle CL01 CL02)
       DEG# (EARTH_RTD RAD#)
       DLEN (distance CL01 CL02)
       CL01 (trans CL01 1 0)
       CL02 (trans CL02 1 0)
       PT01 CL01
       PT02 (polar PT01 (EARTH_DTR (+ DEG#   0)) DLEN)
       PT03 (polar PT01 (EARTH_DTR (+ DEG# 270)) HWID)
       PT04 (polar PT02 (EARTH_DTR (+ DEG# 270)) HWID))
 (EARTH_CPS)
 (EARTH_ML "HATCH" 1 "Continuous" 18) ;Set layer name, color, linetype, & lineweight
 (setvar "clayer" "HATCH")            ;Set HATCH layer current
 (entmake
   (list
     (cons 0   "LWPOLYLINE")
     (cons 100 "AcDbEntity")
     (cons 67   0)
     (cons 410 "Model")
     (cons 8   "0")
     (cons 100 "AcDbPolyline")
     (cons 90   4)
     (cons 70   1)
     (cons 43   0.0)
     (cons 38   0.0)
     (cons 39   0.0)
     (cons 10   PT01)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 10   PT02)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 10   PT04)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 10   PT03)
     (cons 40   0.0)
     (cons 41   0.0)
     (cons 42   0.0)
     (cons 210 (list 0.0 0.0 1.0))))
 (setq E01 (entlast))
 (entmake
   (list
     (cons 0   "HATCH")
     (cons 100 "AcDbEntity")
     (cons 67   0)
     (cons 410 "Model")
     (cons 8   "HATCH")
     (cons 100 "AcDbHatch")
     (cons 10  (list  0.0 0.0 0.0))
     (cons 210 (list  0.0 0.0 1.0))
     (cons 2    HPRP)
     (cons 70   0)
     (cons 71   0)
     (cons 91   1)
     (cons 92   1)
     (cons 93   4)
     (cons 72   1)
     (cons 10   PT01)
     (cons 11   PT02)
     (cons 72   1)
     (cons 10   PT02)
     (cons 11   PT04)
     (cons 72   1)
     (cons 10   PT04)
     (cons 11   PT03)
     (cons 72   1)
     (cons 10   PT03)
     (cons 11   PT01)
     (cons 97   0)
     (cons 75   0)
     (cons 76   1)
     (cons 52   HANG)
     (cons 41   HSCL)
     (cons 77   0)
     (cons 78   6)
     (cons 53   0.785398)
     (cons 43   0.0)
     (cons 44   0.0)
     (cons 45   2.22045e-016)
     (cons 46   2.12132)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   0.785398)
     (cons 43  -0.397748)
     (cons 44   0.397748)
     (cons 45   2.22045e-016)
     (cons 46   2.12132)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   0.785398)
     (cons 43  -0.795495)
     (cons 44   0.795495)
     (cons 45   2.22045e-016)
     (cons 46   2.12132)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   2.35619)
     (cons 43  -0.795495)
     (cons 44   1.06066)
     (cons 45  -2.12132)
     (cons 46   4.44089e-016)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   2.35619)
     (cons 43  -0.397748)
     (cons 44   1.45841)
     (cons 45  -2.12132)
     (cons 46   4.44089e-016)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 53   2.35619)
     (cons 43   1.11022e-016)
     (cons 44   1.85616)
     (cons 45  -2.12132)
     (cons 46   4.44089e-016)
     (cons 79   2)
     (cons 49   1.5)
     (cons 49  -1.5)
     (cons 98   1)
     (cons 10  (list  0.0 0.0 0.0))))
 (entdel  E01)
 (setenv "MaxHatch" "100")
 (EARTH_RUS)
 (princ))
(princ)
(princ "\nEARTH.lsp loaded... Type EARTH to start.")
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Degrees To Radians.
;
(defun EARTH_DTR (DEG#)(* pi (/ DEG# 180.0)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Radians To Degrees.
;
(defun EARTH_RTD (RAD#)(* 180.0 (/ RAD# pi)))
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Make Layer.
;
(defun EARTH_ML (LNAM LCLR LTYP LWGT)
 (if (null (tblsearch "layer" LNAM))
   (entmake
     (list
       (cons   0 "LAYER")
       (cons 100 "AcDbSymbolTableRecord")
       (cons 100 "AcDbLayerTableRecord")
       (cons   2  LNAM)
       (cons  70  0)
       (cons  62  LCLR)
       (cons   6  LTYP)
       (cons 290  1)
       (cons 370  LWGT))))
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Change Program Settings.
;
(defun EARTH_CPS ()
 (setq CPS (list 0 1 0 0 0 0))
 (mapcar (function setvar)(list "cmdecho" "orthomode" "blipmode" "angbase" "angdir" "aunits") CPS)
 (princ))
(princ)
;
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Restore User Settings.
;
(defun EARTH_RUS ()
 (setq *error* TERR)
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has completed successfully and will now restore your settings.")
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////
;
; Error Trap.
;
(defun EARTH_ET (ERRORMSG)
 (command nil nil nil)
 (if (not (member ERRORMSG '("console break" "Function cancelled")))
   (princ (strcat "\nError:" ERRORMSG)))
 (if SUS (mapcar 'setvar SUS_LST SUS))
 (princ "\nEARTH.lsp has encountered a user error!")
 (princ "\nProgram will now restore your settings and exit.")
 (terpri)
 (setq *error* TERR)
 (princ))
(princ)
;
;/////////////////////////////////////////////////////////////////////////////////////////

Edited August 1, 2010 by The Buzzard

[alanjt]

Occurrences such at the above can generally be attributed to running OSnaps.

[The Buzzard]

Occurrences such at the above can generally be attributed to running OSnaps.

 

Thanks alan, But I am not setting osnaps although others may have them set. I should have disabled them, But with entmake thats not an issue. I cannot get over the difference in speed to execute the program from start to finish. Its a world of a difference.

[alanjt]

Thanks alan, But I am not setting osnaps although others may have them set. I should have disabled them, But with entmake thats not an issue. I cannot get over the difference in speed to execute the program from start to finish. Its a worl of a difference.

That's what I meant. I know you aren't running them, but that kind of issue screams running OSnaps - never underestimate the power of turning the osnaps off or "_non" before each point input.

 

I'm sure it's a lot faster now. Nice work, I hate dealing with entmake when it comes to hatch.

[The Buzzard]

That's what I meant. I know you aren't running them, but that kind of issue screams running OSnaps - never underestimate the power of turning the osnaps off or "_non" before each point input.

 

I'm sure it's a lot faster now. Nice work, I hate dealing with entmake when it comes to hatch.

 

I know exactly what you mean, I hate dealing with entmake also when it comes down to certain things, But its worth the trouble in the end. Should have done it in the beginning I afraid to say.