Author Topic: block bottom WIPEOUT (or solid hatch)  (Read 7045 times)

0 Members and 1 Guest are viewing this topic.

domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #15 on: March 25, 2021, 01:37:16 AM »
Why do you create a quad of boundaries? This took me a minute to hatch using a single rectangle around the car.

look at the attachments


domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #16 on: March 25, 2021, 03:01:18 AM »
another thing that might be useful is
to zoom in,
on the outer rectangle,
before to pick bhatch points

danAllen

  • Newt
  • Posts: 132
Re: block bottom WIPEOUT (or solid hatch)
« Reply #17 on: March 25, 2021, 11:27:54 AM »
I typically use BPOLY instead of bhatch to do this

ronjonp

  • Needs a day job
  • Posts: 7526
Re: block bottom WIPEOUT (or solid hatch)
« Reply #18 on: March 25, 2021, 12:23:41 PM »
I typically use BPOLY instead of bhatch to do this
One advantage of hatch is you can up the HPGAPTOL number to fill in any imperfections which the OP was having issues with.
« Last Edit: March 25, 2021, 12:29:24 PM by ronjonp »

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #19 on: March 26, 2021, 07:14:10 AM »
https://drive.google.com/file/d/177urbYaXsFQL_zSuELpzA3p5lnlkbXlv/view?usp=sharing

Code - Auto/Visual Lisp: [Select]
  1. (defun MID ( a b )      (mapcar (function (lambda ( a b ) (/ (+ a b) 2.0))) a b)        )       ;       Lee Mac
  2.  
  3. (defun :ENTER_TO_CONTINUE () (getstring "\nenter to continue :"))
  4.  
  5. ;; Entnext to End  -  Lee Mac
  6. ;; Returns a list of all primary entities after a given entity in the drawing database
  7. (defun LM:ENTNEXTTOEND ( ent / tmp )
  8.    (if (setq tmp (entnext ent))
  9.        (if (member (cdr (assoc 0 (entget ent))) '("ATTRIB" "VERTEX" "SEQEND"))
  10.            (LM:entnexttoend tmp)
  11.            (cons tmp (LM:entnexttoend tmp))
  12.        )
  13.    )
  14. )
  15.  
  16. ;; Entlast  -  Lee Mac
  17. ;; Returns the last entity in the drawing database after a given entity
  18. (defun LM:ENTLAST ( ent / tmp )
  19.    (if (setq tmp (entnext ent)) (LM:entlast tmp) ent)
  20. )
  21.  
  22.  
  23.  
  24. (defun LM:ssget ( msg arg / sel )
  25.     (princ msg)
  26.     (setvar 'nomutt 1)
  27.     (setq sel (vl-catch-all-apply 'ssget arg))
  28.     (setvar 'nomutt 0)
  29.     (if (not (vl-catch-all-error-p sel)) sel)
  30. )
  31.  
  32. ;; Block Reference Bounding Box  -  Lee Mac
  33. ;; Returns a WCS point list describing a rectangular frame bounding all geometry of a supplied block reference.
  34. ;; Excludes Text, MText & Attribute Definitions.
  35. ;; ref - [vla] Block Reference Object
  36.  
  37. (defun LM:blockreferenceboundingbox     (ref)
  38.         (
  39.          (lambda        (lst)
  40.                  (apply
  41.                          (function
  42.                                  (lambda        (m v)
  43.                                          (mapcar (function (lambda (p) (mapcar '+ (mxv m p) v))) lst)
  44.                                  )
  45.                          )
  46.                          (refgeom (vlax-vla-object->ename ref))
  47.                  )
  48.          )
  49.                 (LM:blockdefinitionboundingbox
  50.                         (vla-item
  51.                                 (vla-get-blocks (vla-get-document ref))
  52.                                 (vla-get-name ref)
  53.                         )
  54.                 )
  55.         )
  56. )
  57.  
  58. ;; Block Definition Bounding Box  -  Lee Mac
  59. ;; Returns a WCS point list describing a rectangular frame bounding all geometry of a supplied block definition.
  60. ;; Excludes Text, MText & Attribute Definitions.
  61. ;; def - [vla] Block Definition Object
  62.  
  63. (defun LM:blockdefinitionboundingbox (def / llp lst urp)
  64.         (vlax-for obj def
  65.                 (cond
  66.                         ((= :vlax-false (vla-get-visible obj)))
  67.                         ((= "AcDbBlockReference" (vla-get-objectname obj))
  68.                          (setq lst (append lst (LM:blockreferenceboundingbox obj)))
  69.                         )
  70.                         ((and   (not (wcmatch (vla-get-objectname obj)
  71.                                                                           "AcDbAttributeDefinition,AcDb*Text"
  72.                                                   )
  73.                                         )
  74.                                         (vlax-method-applicable-p obj 'getboundingbox)
  75.                                         (not (vl-catch-all-error-p
  76.                                                           (vl-catch-all-apply
  77.                                                                   'vla-getboundingbox
  78.                                                                   (list obj 'llp 'urp)
  79.                                                           )
  80.                                                   )
  81.                                         )
  82.                          )
  83.                          (setq lst (vl-list*    (vlax-safearray->list llp)
  84.                                                                                 (vlax-safearray->list urp)
  85.                                                                                 lst
  86.                                                   )
  87.                          )
  88.                         )
  89.                 )
  90.         )
  91.         (LM:points->boundingbox lst)
  92. )
  93.  
  94. ;; Point to Bounding Box  -  Lee Mac
  95. ;; Returns the rectangular extents of a supplied point list
  96.  
  97. (defun LM:points->boundingbox   (lst)
  98.         ((lambda        (l)
  99.                  (mapcar        '(lambda (a) (mapcar '(lambda (b) ((eval b) l)) a))
  100.                                         '(
  101.                                           (caar cadar)
  102.                                           (caadr cadar)
  103.                                           (caadr cadadr)
  104.                                           (caar cadadr)
  105.                                          )
  106.                  )
  107.          )
  108.                 (mapcar '(lambda (f) (apply 'mapcar (cons f lst)))
  109.                                   '(min max)
  110.                 )
  111.         )
  112. )
  113.  
  114. ;; RefGeom (gile)
  115. ;; Returns a list which first item is a 3x3 transformation matrix (rotation, scales, normal)
  116. ;; and second item the object insertion point in its parent (xref, block or space)
  117. ;; Argument : an ename
  118.  
  119. (defun refgeom  (ent / ang ang mat ocs)
  120.         (setq   enx (entget ent)
  121.                         ang (cdr (assoc 050 enx))
  122.                         ocs (cdr (assoc 210 enx))
  123.         )
  124.         (list
  125.                 (setq   mat
  126.                                   (mxm
  127.                                           (mapcar '(lambda (v) (trans v 0 ocs t))
  128.                                                                  '(
  129.                                                                         (1.0 0.0 0.0)
  130.                                                                         (0.0 1.0 0.0)
  131.                                                                         (0.0 0.0 1.0)
  132.                                                                   )
  133.                                           )
  134.                                           (mxm
  135.                                                   (list
  136.                                                           (list (cos ang) (- (sin ang)) 0.0)
  137.                                                           (list (sin ang) (cos ang) 0.0)
  138.                                                           '(0.0 0.0 1.0)
  139.                                                   )
  140.                                                   (list
  141.                                                           (list (cdr (assoc 41 enx)) 0.0 0.0)
  142.                                                           (list 0.0 (cdr (assoc 42 enx)) 0.0)
  143.                                                           (list 0.0 0.0 (cdr (assoc 43 enx)))
  144.                                                   )
  145.                                           )
  146.                                   )
  147.                 )
  148.                 (mapcar '-
  149.                                   (trans (cdr (assoc 10 enx)) ocs 0)
  150.                                   (mxv mat
  151.                                                  (cdr (assoc 10 (tblsearch "block" (cdr (assoc 2 enx)))))
  152.                                   )
  153.                 )
  154.         )
  155. )
  156.  
  157. ;; Matrix x Vector - Vladimir Nesterovsky
  158. ;; Args: m - nxn matrix, v - vector in R^n
  159.  
  160. (defun mxv (m v)
  161.         (mapcar '(lambda (r) (apply '+ (mapcar '* r v))) m)
  162. )
  163.  
  164. ;; Matrix Transpose - Doug Wilson
  165. ;; Args: m - nxn matrix
  166.  
  167. (defun trp (m)
  168.         (apply 'mapcar (cons 'list m))
  169. )
  170.  
  171. ;; Matrix x Matrix - Vladimir Nesterovsky
  172. ;; Args: m,n - nxn matrices
  173.  
  174. (defun mxm (m n)
  175.         ((lambda (a) (mapcar '(lambda (r) (mxv a r)) m)) (trp n))
  176. )
  177.  
  178.  
  179.  
  180.  
  181. ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  182. ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  183. ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  184. (defun C:BOTTOM-HATCH   (       /
  185.                                                                         BOUNDARY-SET BOUNDARY-SET-S BR-BB BR-EN BR-ES BR-OBJ DIAGONAL E-BASE E-DX
  186.                                                                         E-DY E-HEIGHT E-LL E-LR E-PLINE-V-LIST E-UL E-UR H-EN I I-BASE I-HEIGHT I-LL
  187.                                                                         I-LR I-UL I-UR IND INT-LST J LL-BASE-PP N-X-DIV N-Y-DIV NEW-EN-LST OFFSET PI/4
  188.                                                                         PICK-POINT-LIST PPL PT SS-TO-ERASE X-E-LL-O X-ENTLAST X-INT-LST X-LOWER-PP-LST
  189.                                                                         X-LOWER-PT-LST X-UPPER-PP-LST X-UPPER-PT-LST Y-E-LL-O Y-INT-LST Y-LEFT-PP-LST Y-LEFT-PT-LST
  190.                                                                         Y-RIGHT-PP-LST Y-RIGHT-PT-LST
  191.                                                                 )
  192.         ;               the insert must have ROTATION ANGLE = 0.0      
  193.         ;               and CANNOT CONTAIN HATCHS and SPLINES                  
  194.         (if(and
  195.                         (setq br-es                     (entsel "\nselect the block to fill on the bottom :") )
  196.                         (setq br-en                     (car br-es) )
  197.                         (setq br-obj                    (vlax-ename->vla-object br-en ) )
  198.                         (setq br-bb                     (LM:BLOCKREFERENCEBOUNDINGBOX br-obj ) )
  199.                         (setq i-ll                              (nth 0 br-bb)
  200.                                         i-lr                            (nth 1 br-bb)
  201.                                         i-ur                            (nth 2 br-bb)
  202.                                         i-ul                            (nth 3 br-bb)
  203.                                         i-height                        (distance i-lr i-ur)
  204.                                         i-base                  (distance i-ll i-lr)
  205.                                         offset                  (/ i-height 20.0)                      
  206.                                         diagonal                        (* offset (sqrt 2.0) )
  207.                                         pi/4                            (/ pi 4.0)
  208.                                         e-ll                            (polar i-ll (* pi/4 5.0) diagonal)
  209.                                         e-lr                            (polar i-lr (* pi/4 7.0) diagonal)
  210.                                         e-ur                            (polar i-ur (* pi/4 1.0) diagonal)
  211.                                         e-ul                            (polar i-ul (* pi/4 3.0) diagonal)
  212.                                         e-height                        (distance e-lr e-ur)
  213.                                         e-base                  (distance e-ll e-lr)
  214.                                         int-lst                 '(20 19 18 17 16 15 14 13 12 11 10 9 8 7 6 5 4 3 2 1)
  215.                                         ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  216.                                         n-y-div                 6.0
  217.                                         y-int-lst               (reverse (member (fix (- n-y-div 1 ) ) int-lst  ) )
  218.                                         e-dy                            (/ e-height n-y-div)
  219.                                         y-e-ll-o                        (polar e-ll pi offset)
  220.                                         y-left-pt-lst   (mapcar '(lambda (i) (polar y-e-ll-o (* pi/4 2.0) (* e-dy (float i) ) ) ) y-int-lst )  
  221.                                         y-right-pt-lst (mapcar '(lambda (i) (polar i 0.0 (+ e-base offset offset ) ) ) y-left-pt-lst )
  222.  
  223.                                         ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  224.                                         n-x-div                 6.0
  225.                                         x-int-lst               (reverse (member (fix (- n-x-div 1 ) ) int-lst  ) )
  226.                                         e-dx                            (/ e-base n-x-div)
  227.                                         x-e-ll-o                        (polar e-ll (* pi/4 6.0) offset)
  228.                                         x-lower-pt-lst (mapcar '(lambda (i) (polar x-e-ll-o  0.0 (* e-dx (float i) ) ) ) x-int-lst )   
  229.                                         x-upper-pt-lst (mapcar '(lambda (i) (polar i (* pi/4 2.0) (+ e-height offset offset ) ) ) x-lower-pt-lst )
  230.  
  231.                                         ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  232.                                         ll-base-pp              (polar e-ll (* pi/4 6.0) (+ (/ e-dy 2.0) ) )
  233.                                         ll-base-pp              (polar ll-base-pp 0.0 (* offset 0.5) )
  234.                                         y-int-lst               (reverse (member (fix n-y-div ) int-lst  ) )
  235.                                         y-left-pp-lst   (mapcar '(lambda (i) (polar ll-base-pp  (* pi/4 2.0) (* e-dy (float i) ) ) ) y-int-lst )
  236.                                         y-right-pp-lst (mapcar '(lambda (i) (polar i 0.0 (+ i-base offset) ) ) y-left-pp-lst )
  237.  
  238.  
  239.  
  240.  
  241.                                        
  242.                                         ;       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -       -
  243.                                         ll-base-pp              (polar e-ll pi  (+ (/ e-dx 2.0) ) )
  244.                                         ll-base-pp              (polar ll-base-pp (* pi/4 2.0) (/ offset 2.0) )
  245.                                         x-int-lst               (reverse (member (fix n-x-div ) int-lst  ) )
  246.                                         x-lower-pp-lst  (mapcar '(lambda (i) (polar ll-base-pp  0.0 (* e-dx (float i) ) ) ) x-int-lst )
  247.                                         x-upper-pp-lst (mapcar '(lambda (i) (polar i (* pi/4 2.0) (+ i-height offset) ) ) x-lower-pp-lst )
  248.  
  249.                                         pick-point-list (apply' append (mapcar 'cdr (list       x-lower-pp-lst  y-right-pp-lst  (reverse x-upper-pp-lst) (reverse y-left-pp-lst ) ) ) )
  250.  
  251.                         )
  252.                 )
  253.                 t
  254.                 (exit)
  255.         )
  256.  
  257.         (command "zoom" "w" e-ll e-ur)
  258. (:ENTER_TO_CONTINUE)
  259.         (command "zoom" "s" "0.9x")
  260. (:ENTER_TO_CONTINUE)
  261.        
  262.         (setvar "osmode" 0)
  263.  
  264.        
  265.         (setq x-entlast (LM:ENTLAST (entlast) ) )
  266.  
  267.         (setq e-pline-v-list (list e-ll e-lr e-ur e-ul e-ll) )
  268.  
  269.         (entmakex
  270.                 (append
  271.                         '((0 . "LWPOLYLINE") (100 . "AcDbEntity") (100 . "AcDbPolyline") (8 . "0") (90 . 5) (70 . 1))
  272.         (mapcar '(lambda (pt) (cons 10 pt)) e-pline-v-list)
  273.       )
  274.    )
  275. (:ENTER_TO_CONTINUE)   
  276.         (mapcar '(lambda (i j) (vla-AddLine *model-space* (vlax-3d-point i) (vlax-3d-point j) ) ) y-left-pt-lst  y-right-pt-lst)
  277. (:ENTER_TO_CONTINUE)   
  278.         (mapcar '(lambda (i j) (vla-AddLine *model-space* (vlax-3d-point i) (vlax-3d-point j) ) ) x-lower-pt-lst x-upper-pt-lst)
  279. (:ENTER_TO_CONTINUE)
  280.         (setq new-en-lst (LM:ENTNEXTTOEND x-entlast) )
  281.        
  282.         (setq ind 0 boundary-set (ssadd br-en) )
  283.         (repeat (length new-en-lst) (setq boundary-set (ssadd (nth ind new-en-lst) boundary-set)        ind (+ 1 ind) ) )
  284.  
  285.         (setq ppl pick-point-list)
  286.         (vl-cmdf "_-bhatch" "_a" "_b" "_n" boundary-set "" "")
  287.         (while ppl (command (car ppl)) (setq ppl (cdr ppl) )  )
  288.         (command "")
  289.         (setq h-en (entlast) )
  290. (:ENTER_TO_CONTINUE)   
  291.         (setq new-en-lst (LM:ENTNEXTTOEND x-entlast) ) 
  292.         (setq ss-to-erase (ssadd) ind 0)
  293.         (repeat (length new-en-lst) (setq ss-to-erase (ssadd (nth ind new-en-lst) ss-to-erase)  ind (+ 1 ind) ) )
  294.         (setq ss-to-erase (ssdel (entlast) ss-to-erase) )
  295.         (command "erase" ss-to-erase "")
  296.  
  297. (:ENTER_TO_CONTINUE)
  298.         (setq x-entlast (LM:ENTLAST h-en ) )
  299.         (command "HATCHGENERATEBOUNDARY" h-en "")
  300.         (entdel h-en)
  301.         (setq new-en-lst (LM:ENTNEXTTOEND x-entlast) ) 
  302.         (setq ss-to-erase (ssadd) ind 0)
  303.         (repeat (length new-en-lst) (setq ss-to-erase (ssadd (nth ind new-en-lst) ss-to-erase)  ind (+ 1 ind) ) )
  304. (:ENTER_TO_CONTINUE)
  305.         (vla-put-Visible br-obj :vlax-false)
  306. (:ENTER_TO_CONTINUE)   
  307.         (vl-cmdf "_-bhatch" "_a" "_b" "_n" ss-to-erase "" "" (mid i-ll i-ur) "")
  308. (:ENTER_TO_CONTINUE)   
  309.         (command "erase" ss-to-erase "")
  310. (:ENTER_TO_CONTINUE)
  311.         (vla-put-Visible br-obj :vlax-true)
  312.         (command "draworder" (entlast) "" "back")
  313.        
  314. )
  315.  
  316.  
  317.  
  318. (defun c:K () (C:BOTTOM-HATCH) )
  319.  
« Last Edit: March 26, 2021, 08:28:44 AM by domenicomaria »

domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #20 on: March 26, 2021, 07:18:02 AM »
the code needs to be improved a lot,
. . .
towards the end it is a little confusing
. . .
but it works
. . .
you can decide the number of horizontal and vertical divisions. . .
...
as soon as I have a little time,
I will improve it and make it more readable
. . .
I have not used
BHGAPTOL
. . .
but still it must be taken into consideration
. . .
however, it is not the solution, but it is probably the way
« Last Edit: March 26, 2021, 10:03:38 AM by domenicomaria »

domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #21 on: March 26, 2021, 08:34:33 AM »
i forgot to add
(setvar "hpname" "solid")
« Last Edit: March 26, 2021, 10:03:59 AM by domenicomaria »

danAllen

  • Newt
  • Posts: 132
Re: block bottom WIPEOUT (or solid hatch)
« Reply #22 on: March 26, 2021, 11:52:17 AM »
One advantage of hatch is you can up the HPGAPTOL number to fill in any imperfections which the OP was having issues with.

At least in Bricscad v15, both BHATCH & BPOLY use HPGAPTOL

ronjonp

  • Needs a day job
  • Posts: 7526
Re: block bottom WIPEOUT (or solid hatch)
« Reply #23 on: March 26, 2021, 01:20:30 PM »
One advantage of hatch is you can up the HPGAPTOL number to fill in any imperfections which the OP was having issues with.

At least in Bricscad v15, both BHATCH & BPOLY use HPGAPTOL
You're talking about a progressive CAD platform vs. AutoCAD :evil:

Just checked in AutoCAD 2022 and it's still the same.

Windows 11 x64 - AutoCAD /C3D 2023

Custom Build PC

Marc'Antonio Alessi

  • Swamp Rat
  • Posts: 1451
  • Marco
Re: block bottom WIPEOUT (or solid hatch)
« Reply #24 on: March 26, 2021, 01:46:38 PM »
One advantage of hatch is you can up the HPGAPTOL number to fill in any imperfections which the OP was having issues with.

At least in Bricscad v15, both BHATCH & BPOLY use HPGAPTOL
You're talking about a progressive CAD platform vs. AutoCAD :evil:

Just checked in AutoCAD 2022 and it's still the same.
V15... it is a very far progress…  :whistling:

domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #25 on: March 27, 2021, 03:05:23 AM »
https://drive.google.com/file/d/1gaySQZqUzguKudx-qNrcwz1fgrQZQh3n/view?usp=sharing

it is important to set the number of horizontal and vertical divisions

and HPGAPTOL too

and set "hpname" to "solid"

I want try to write a "circular" version . . . using a circle, instead of a rectangle


domenicomaria

  • Swamp Rat
  • Posts: 723
Re: block bottom WIPEOUT (or solid hatch)
« Reply #27 on: March 28, 2021, 01:36:38 PM »
BOTTOM-HATCH-CIRCULAR

Often it works.
Mainly with simple shapes.

But if it doesn't work,
it depends also
from the ACAD algorithm for BATCH.

Because it is NOT PERFECT !



Code - Auto/Visual Lisp: [Select]
  1. (setq *DEBUG-IS-ALIVE* T)
  2.  
  3.  
  4. (defun :ENTER_TO_CONTINUE ()
  5.    (if *DEBUG-IS-ALIVE*
  6.       (getstring "\nenter to continue :")
  7.       nil
  8.    )
  9. )
  10.  
  11. ;   LEE MAC MID   ... renamed ...
  12. (defun MID-2P (a b)
  13.    (mapcar (function (lambda (a b) (/ (+ a b) 2.0))) a b)  
  14. )
  15.  
  16.    ;   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -   -
  17. (defun C:BOTTOM-HATCH-CIRCULAR (/             ALL-EN-LST      BOUNDARY-SET  BR-BB
  18.                                 BR-EN          BR-ES         BR-OBJ        BR-SS
  19.                                 CENTER          CRCL-EN         CRCL-OBJ        GENERATED-BOUNDARY-EN-LST
  20.                                 GENERATED-BOUNDARY-SS         HATCH-EN        HATCH-ENTLAST
  21.                                 HPGAPTOL       I-LL            I-LR           I-UL
  22.                                 I-UR          INC-ANG         IND           L-X
  23.                                 L-Y             LINES-EN-LST   LINES-ENTLAST N-DIV
  24.                                 OFFSET          OLD-HPGAPTOL   OLD-N-DIV     PP-LST
  25.                                 R-X             RADIUS         RADIUS-E        RADIUS-EE
  26.                                 RADIUS-I       START-ANG      U-Y           VLA-CENTER
  27.                                 Z-LL          Z-UR
  28.                                )
  29.  
  30.  
  31.    (setvar "osmode" 0)
  32.    (setvar "hpname" "solid")
  33.    (setvar "dimzin" 0)
  34.    (setq   *model-space*
  35.            (vla-get-modelspace
  36.            )
  37.    )
  38.  
  39.    ;   -   -   -
  40.    (setq old-n-div 5)
  41.    (if (not
  42.           (setq n-div (getint   (strcat "\nnumber of angular divisions < "
  43.                                       (itoa old-n-div)
  44.                                       " > :"
  45.                               )
  46.                       )
  47.           )
  48.        )
  49.       (setq n-div old-n-div)
  50.    )
  51.  
  52.    ;   -   -   -  
  53.    (setq old-hpgaptol (getvar "hpgaptol"))
  54.    (if (not
  55.           (setq hpgaptol (getdist
  56.                             (strcat "\nHPGAPTOL < " (rtos old-hpgaptol 2 2) " > : ")
  57.                          )
  58.           )
  59.        )
  60.       (setq hpgaptol old-hpgaptol)
  61.    )
  62.    (setvar "hpgaptol" hpgaptol)
  63.  
  64.    ;      the insert must have ROTATION ANGLE = 0.0    
  65.    ;      and CANNOT CONTAIN HATCHS and SPLINES        
  66.    (if (and
  67.           (setq br-es (entsel "\nselect the block to FILL on the BOTTOM :"))
  68.           (setq br-en (car br-es))
  69.           (setq br-obj (vlax-ename->vla-object br-en))
  70.           (setq br-ss (ssadd))
  71.           (setq br-ss (ssadd br-en br-ss))
  72.           (setq br-bb (LM:BLOCKREFERENCEBOUNDINGBOX br-obj))
  73.           (setq i-ll         (nth 0 br-bb)
  74.                 i-lr         (nth 1 br-bb)
  75.                 i-ur         (nth 2 br-bb)
  76.                 i-ul         (nth 3 br-bb)
  77.                 center      (MID-2P i-ll i-ur)
  78.                 vla-center   (vlax-3d-point center)
  79.                 radius      (/ (distance i-ll i-ur) 2.0)
  80.                 offset      (/ radius 20.0)
  81.                 radius-e   (+ radius offset)
  82.                 radius-ee   (+ radius (* 1.5 offset))
  83.                 radius-i   (+ radius (/ offset 2.0))
  84.                 l-x         (- (car center) radius-e)
  85.                 r-x         (+ (car center) radius-e)
  86.                 l-y         (- (cadr center) radius-e)
  87.                 u-y         (+ (cadr center) radius-e)
  88.                 z-ll         (list l-x l-y)
  89.                 z-ur         (list r-x u-y)
  90.           )
  91.        )
  92.       t
  93.       (exit)
  94.    )
  95.  
  96.    (command "zoom" "w" z-ll z-ur)
  97.    (:ENTER_TO_CONTINUE)
  98.    (command "zoom" "s" "0.9x")
  99.    (:ENTER_TO_CONTINUE)
  100.  
  101.    (setq crcl-obj (vla-AddCircle *model-space* vla-center radius-e))
  102.    (setq crcl-en (vlax-vla-object->ename crcl-obj))
  103.  
  104.  
  105.    ;   (command "line" z-ll z-ur "")  
  106.  
  107.  
  108.    (:ENTER_TO_CONTINUE)
  109.    (setq lines-entlast (LM:ENTLAST (entlast)))
  110.  
  111.    (setq inc-ang (/ (* pi 2) (float n-div)))
  112.    (setq ind 1)
  113.    (repeat n-div
  114.       (vla-addline
  115.          *model-space*
  116.          vla-center
  117.          (vlax-3d-point (polar center (* inc-ang ind) radius-ee))
  118.       )
  119.       (setq ind (+ 1 ind))
  120.    )
  121.    (setq lines-en-lst (LM:ENTNEXTTOEND lines-entlast))
  122.  
  123.  
  124.  
  125.  
  126.  
  127.    (setq   ind       0
  128.          start-ang (/ inc-ang 2.0)
  129.    )
  130.    (repeat n-div
  131.       (setq   pp-lst (cons (polar center (+ start-ang (* inc-ang ind)) radius-i)
  132.                          pp-lst
  133.                    )
  134.       )
  135.       (setq ind (+ 1 ind))
  136.    )
  137.  
  138.  
  139.  
  140.  
  141.    (:ENTER_TO_CONTINUE)
  142.    (setq   ind 0
  143.          boundary-set
  144.            (ssadd br-en)
  145.          all-en-lst
  146.            (append lines-en-lst (list crcl-en))
  147.    )
  148.    (repeat (length all-en-lst)
  149.       (setq   boundary-set
  150.               (ssadd (nth ind all-en-lst) boundary-set)
  151.             ind (+ 1 ind)
  152.       )
  153.    )
  154.  
  155.  
  156.    (vl-cmdf   "_-bhatch" "_a" "_b"   "_n" boundary-set   ""   "_a" "_n" "")
  157.    (while pp-lst
  158.       (command (car pp-lst))
  159.       (setq pp-lst (cdr pp-lst))
  160.    )
  161.    (command "")
  162.    (setq hatch-en (entlast))
  163.    (:ENTER_TO_CONTINUE)
  164.  
  165.  
  166.  
  167.  
  168.  
  169.    (setq hatch-entlast (LM:ENTLAST hatch-en))
  170.    (command "HATCHGENERATEBOUNDARY" hatch-en "")
  171.    (entdel hatch-en)
  172.    (setq generated-boundary-en-lst (LM:ENTNEXTTOEND hatch-entlast))
  173.    (setq   generated-boundary-ss
  174.            (ssadd)
  175.          ind 0
  176.    )
  177.    (repeat (length generated-boundary-en-lst)
  178.       (setq   generated-boundary-ss
  179.               (ssadd   (nth ind generated-boundary-en-lst)
  180.                      generated-boundary-ss
  181.               )
  182.             ind (+ 1 ind)
  183.       )
  184.    )
  185.    (:ENTER_TO_CONTINUE)
  186.  
  187.    (vl-cmdf "erase" boundary-set hatch-en "r" br-en "")
  188.  
  189.    (vla-put-Visible br-obj :vlax-false)
  190.    (:ENTER_TO_CONTINUE)
  191.    (vl-cmdf   "_-bhatch" "_a" "_b"   "_n" generated-boundary-ss   ""   ""   center "")
  192.    (:ENTER_TO_CONTINUE)
  193.  
  194.    (vl-cmdf "erase" generated-boundary-ss "")
  195.    (:ENTER_TO_CONTINUE)
  196.    (vla-put-Visible br-obj :vlax-true)
  197.    (command "draworder" (entlast) "" "back")
  198.  
  199.  
  200. )
  201.  
  202.  
  203.  
  204. (defun C:Y () (C:BOTTOM-HATCH-CIRCULAR))
  205.