Author Topic: Combining routines issue...  (Read 1437 times)

0 Members and 1 Guest are viewing this topic.

danglar

  • Newt
  • Posts: 161
  • Read My Li(s)(p)
Combining routines issue...
« on: April 03, 2017, 09:43:07 AM »
Hi All.

This lisp can to draw ditch from polyline and hatch it inside with option to change hatch properties:
Code - Auto/Visual Lisp: [Select]
  1. ;;; Draw ditch from polyline and hatch it inside with option to change hatch properties
  2. ;;; Combined from existing routines with great respect to it authors by Igal Averbuh 2017
  3.  
  4. (defun c:dhe ( / *error* GetHatchNames Sel Ent EntData oData nStyle BasePt HatchList Pos
  5.     TogAngle tempList tempPt tempData )
  6.    
  7.     (defun *error* ( msg )
  8.        
  9.         (vl-bt)
  10.         (if oData (entmake oData))
  11.         (if Ent (entdel Ent))
  12.         (if msg (prompt (strcat "\n Error-> " msg)))
  13.         (redraw)
  14.     )
  15.     ;--------------------------------
  16.     (defun GetHatchNames ( filePath / Opened tempStr tempPos tempName HatchList )
  17.        
  18.         (if (setq Opened (open filePath "r"))
  19.             (while (setq tempStr (read-line Opened))
  20.                 (if
  21.                     (and
  22.                         (= (substr tempStr 1 1) "*")
  23.                         (setq tempPos (vl-string-search "," tempStr))
  24.                         (setq tempName (substr tempStr 2 (1- tempPos)))
  25.                         (/= (strcase tempName) "SOLID")
  26.                     )
  27.                     (setq HatchList (cons tempName HatchList))
  28.                 )
  29.             )
  30.         )
  31.         (if Opened (close Opened))
  32.         (reverse HatchList)
  33.     )
  34.     ;------------------------------------
  35.     (if
  36.         (and
  37.             (setq Sel (entsel "\n Select hatch to edit dynamicly: "))
  38.             (setq oData (entget (car Sel)))
  39.             (= (cdr (assoc 0 oData)) "HATCH")
  40.             (setq nStyle (cdr (assoc 2 oData)))
  41.             (setq BasePt (cadr Sel))
  42.             (setq HatchList (GetHatchNames (findfile "acad.pat")))
  43.             (setq Pos (vl-position nStyle HatchList))
  44.             (setq TogAngle 0)
  45.         )
  46.         (while
  47.             (and
  48.                 (not
  49.                     (prompt
  50.                         (strcat
  51.                             "\r Current style: "
  52.                             nStyle
  53.                             " , Allow angle change: "
  54.                             (if (zerop TogAngle) "No" "Yes")
  55.                             " [Style / Angle toggle]: "
  56.                         )
  57.                     )
  58.                 )
  59.                 (setq tempList (grread T 11))
  60.                 (not (equal (car tempList) 3))
  61.             )
  62.             (or
  63.                 Ent
  64.                 (setq Ent (car Sel))
  65.             )
  66.             (setq EntData (entget Ent '("*")))
  67.             (cond
  68.                 ( (equal (car tempList) 5)
  69.                     (setq tempPt (cadr tempList))
  70.                     (redraw)
  71.                     (grdraw BasePt tempPt 7)
  72.                     (setq tempData
  73.                         (subst
  74.                             (cons
  75.                                 41
  76.                                 (distance tempPt BasePt)
  77.                                 ;(/ (distance tempPt BasePt) (/ (getvar 'ViewSize) 5.))
  78.                             )
  79.                             (assoc 41 EntData)
  80.                             EntData
  81.                         )
  82.                     )
  83.                     (if (equal TogAngle 1)
  84.                         (setq tempData
  85.                             (subst
  86.                                 (cons 52 (angle BasePt tempPt))
  87.                                 (assoc 52 EntData)
  88.                                 tempData
  89.                             )
  90.                         )
  91.                     )
  92.                     (if (entmake tempData)
  93.                         (progn
  94.                             (entdel Ent)
  95.                             (setq Ent (entlast))
  96.                         )
  97.                     )
  98.                 )
  99.                 ((equal (car tempList) 2)
  100.                     (cond
  101.                         ( (member (cadr tempList) '(83 115))
  102.                             (setq nStyle (nth (setq Pos (1+ Pos)) HatchList))
  103.                             (if (entmake
  104.                                     (subst
  105.                                         (cons 2 nStyle)
  106.                                         (assoc 2 EntData)
  107.                                         EntData
  108.                                     )
  109.                                 )
  110.                                 (progn
  111.                                     (entdel Ent)
  112.                                     (setq Ent (entlast))
  113.                                 )
  114.                             )
  115.                         )
  116.                         ( (member (cadr tempList) '(65 97))
  117.                             (setq TogAngle (abs (1- TogAngle)))
  118.                         )
  119.                     )
  120.                 )
  121.             )
  122.         )
  123.     )
  124.     (redraw)
  125.     (princ)
  126. )
  127.  
  128.  
  129. (defun c:tl2 (/ AT:Offset ent pnt lst)
  130.   ;; Offset selected curve and connect each end (also option to convert to LWPolyline).
  131.   ;; Copyright© Alan J. Thompson, 04.29.10
  132. (setvar "cmdecho" 0)
  133. (defun OC1 (/ AT:Offset ent pnt lst)
  134.   ;; Offset selected curve and connect each end (also option to convert to LWPolyline).
  135.   ;; Copyright© Alan J. Thompson, 04.29.10
  136.  
  137.  
  138.   (defun AT:Offset (O D P / _pt p1 p2 c D g)
  139.     ;; Offset selected object
  140.     ;; O - Object to offset
  141.     ;; D - Distance to offset object
  142.     ;; P - Point on side of object to offset
  143.     ;; Alan J. Thompson, 09.12.09 / 03.25.10
  144.     (setq _pt (lambda (s)
  145.                 (vlax-curve-getPointAtDist O (s (vlax-curve-getDistAtPoint O p1) 0.00001))
  146.               )
  147.     )
  148.     (if (and (setq p1 (vlax-curve-getclosestpointtoprojection O (trans P 1 0) '(0 0 1)))
  149.              (or (setq p2 (setq c (_pt +))) (setq p2 (_pt -)))
  150.              (if (minusp (- (* (- (car p2) (car p1)) (- (cadr (trans P 1 0)) (cadr p1)))
  151.                             (* (- (cadr p2) (cadr p1)) (- (car (trans P 1 0)) (car p1)))
  152.                          )
  153.                  )
  154.                (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
  155.                  (setq D (- (abs D)))
  156.                  (setq D (abs D))
  157.                )
  158.                (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
  159.                  (setq D (abs D))
  160.                  (setq D (- (abs D)))
  161.                )
  162.              )
  163.              (or c (setq D (- D)))
  164.              (not (vl-catch-all-error-p (setq g (vl-catch-all-apply 'vla-offset (list O D)))))
  165.         )
  166.       (car (vlax-safearray->list (vlax-variant-value g)))
  167.     )
  168.   )
  169.  
  170.  
  171.   (and (minusp (getvar 'offsetdist)) (setvar 'offsetdist 1.))
  172.   (cond
  173.     ((and
  174.        (if AT:Entsel
  175.          (setq ent (car (AT:Entsel nil "\nSelect curve: " '("L" (0 . "ARC,LINE,SPLINE,LWPOLYLINE")) nil)))
  176.          (and (setq ent2 nil)
  177.          (command "pedit" "l" "" "" )
  178.               (or (vl-position (cdr (assoc 0 (entget ent))) '("ARC" "LINE" "SPLINE" "LWPOLYLINE"))
  179.                   (alert "Invalid object!")
  180.               )
  181.          )
  182.        )
  183.        (not (initget 6))
  184.        (setvar
  185.          'offsetdist
  186.          (cond
  187.            ((getdist (strcat "\nSpecify offset distance or <" (rtos (getvar 'offsetdist)) ">: ")))
  188.            ((getvar 'offsetdist))
  189.          )
  190.        )
  191.        (setq pnt (getpoint "\nSpecify point on side to offset: "))
  192.        ((lambda (off)
  193.           (if off
  194.             (setq lst (list ent (vlax-vla-object->ename off)))
  195.             (alert "Cannot offset side of curve!")
  196.           )
  197.         )
  198.          (AT:Offset (vlax-ename->vla-object ent) (getvar 'offsetdist) pnt)
  199.        )
  200.  
  201.      )
  202.  
  203.      (or (vlax-curve-isClosed (car lst))
  204.          (setq lst (append
  205.                      (mapcar
  206.                        (function
  207.                          (lambda (a b f)
  208.                            (entmakex
  209.                              (list '(0 . "LINE")
  210.                                    (assoc 8 (entget ent))
  211.                                    (cons 10 (f a))
  212.                                    (cons 11 (f b))
  213.                              )
  214.                            )
  215.                          )
  216.                        )
  217.                        lst
  218.                        (reverse lst)
  219.                        (list vlax-curve-getStartPoint vlax-curve-getEndPoint)
  220.                      )
  221.                      lst
  222.                    )
  223.  
  224.          )
  225.      )
  226.      (initget 0 "Yes No")
  227.      (if (and (> (length lst) 2)
  228.               (eq "Yes"
  229.                   (cond ((getkword "\nConvert to closed LWPolyline? [Yes/No] <Yes>: "))
  230.                         ("Yes")
  231.                   )
  232.               )
  233.          )
  234.        ((lambda (ss)
  235.           (if (zerop (getvar 'peditaccept))
  236.             (vl-cmdf "_.pedit" "_m" ss "" "_y" "_j" "" "")
  237.             (vl-cmdf "_.pedit" "_m" ss "" "_j" "" "")
  238.           )
  239.         )
  240.          ((lambda (l s) (foreach x l (ssadd x s))) lst (ssadd))
  241.        )
  242.      )
  243.     )
  244.   )
  245.   (princ)
  246. )
  247.  
  248. (oc1)
  249.  
  250.  
  251.   (defun AT:Offset (O D P / _pt p1 p2 c D g)
  252.     ;; Offset selected object
  253.     ;; O - Object to offset
  254.     ;; D - Distance to offset object
  255.     ;; P - Point on side of object to offset
  256.     ;; Alan J. Thompson, 09.12.09 / 03.25.10
  257.     (setq _pt (lambda (s)
  258.                 (vlax-curve-getPointAtDist O (s (vlax-curve-getDistAtPoint O p1) 0.00001))
  259.               )
  260.     )
  261.     (if (and (setq p1 (vlax-curve-getclosestpointtoprojection O (trans P 1 0) '(0 0 1)))
  262.              (or (setq p2 (setq c (_pt +))) (setq p2 (_pt -)))
  263.              (if (minusp (- (* (- (car p2) (car p1)) (- (cadr (trans P 1 0)) (cadr p1)))
  264.                             (* (- (cadr p2) (cadr p1)) (- (car (trans P 1 0)) (car p1)))
  265.                          )
  266.                  )
  267.                (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
  268.                  (setq D (- (abs D)))
  269.                  (setq D (abs D))
  270.                )
  271.                (if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
  272.                  (setq D (abs D))
  273.                  (setq D (- (abs D)))
  274.                )
  275.              )
  276.              (or c (setq D (- D)))
  277.              (not (vl-catch-all-error-p (setq g (vl-catch-all-apply 'vla-offset (list O D)))))
  278.         )
  279.       (car (vlax-safearray->list (vlax-variant-value g)))
  280.     )
  281.   )
  282.  
  283.  
  284.   (and (minusp (getvar 'offsetdist)) (setvar 'offsetdist 1.))
  285.   (cond
  286.     ((and
  287.        (if AT:Entsel
  288.          (setq ent (car (AT:Entsel nil "\nSelect curve: " '("L" (0 . "ARC,LINE,SPLINE,LWPOLYLINE")) nil)))
  289.          (and (setq ent (car (entsel "\nSelect curve: ")))
  290.          
  291.               (or (vl-position (cdr (assoc 0 (entget ent))) '("ARC" "LINE" "SPLINE" "LWPOLYLINE"))
  292.                   (alert "Invalid object!")
  293.               )
  294.          )
  295.        )
  296.        (not (initget 6))
  297.        (setvar
  298.          'offsetdist
  299.          (cond
  300.            ((getdist (strcat "\nSpecify offset distance or <" (rtos (getvar 'offsetdist)) ">: ")))
  301.            ((getvar 'offsetdist))
  302.          )
  303.        )
  304.        (setq pnt (getpoint "\nSpecify point on side to offset: "))
  305.        ((lambda (off)
  306.           (if off
  307.             (setq lst (list ent (vlax-vla-object->ename off)))
  308.             (alert "Cannot offset side of curve!")
  309.           )
  310.         )
  311.          (AT:Offset (vlax-ename->vla-object ent) (getvar 'offsetdist) pnt)
  312.        )
  313.  
  314.      )
  315.  
  316.      (or (vlax-curve-isClosed (car lst))
  317.          (setq lst (append
  318.                      (mapcar
  319.                        (function
  320.                          (lambda (a b f)
  321.                            (entmakex
  322.                              (list '(0 . "LINE")
  323.                                    (assoc 8 (entget ent))
  324.                                    (cons 10 (f a))
  325.                                    (cons 11 (f b))
  326.                              )
  327.                            )
  328.                          )
  329.                        )
  330.                        lst
  331.                        (reverse lst)
  332.                        (list vlax-curve-getStartPoint vlax-curve-getEndPoint)
  333.                      )
  334.                      lst
  335.                    )
  336.  
  337.          )
  338.      )
  339.      (initget 0 "Yes No")
  340.      (if (and (> (length lst) 2)
  341.               (eq "Yes"
  342.                   (cond ((getkword "\nConvert to closed LWPolyline? [Yes/No] <Yes>: "))
  343.                         ("Yes")
  344.                   )
  345.               )
  346.          )
  347.        ((lambda (ss)
  348.           (if (zerop (getvar 'peditaccept))
  349.             (vl-cmdf "_.pedit" "_m" ss "" "_y" "_j" "" "")
  350.             (vl-cmdf "_.pedit" "_m" ss "" "_j" "" "")
  351.           )
  352.             (command "-hatch" "s" ss "" "p" "ANSI37" "5" "45" "")
  353.         )
  354.          ((lambda (l s) (foreach x l (ssadd x s))) lst (ssadd))
  355.        )
  356.      )
  357.     )
  358.   )
  359.   (princ)
  360. (setvar "cmdecho" 1)
  361. )
  362.  
  363.  
  364. (defun c:tl ()
  365. (c:tl2)
  366. (c:dhe)
  367. )
  368. (c:tl)
  369.  
  370.  
  371.  

as usual for me it working properly, but... "dirty".

 

Lisp have at least two problems

1. User need to select hatch inside closed polyline in order to change it properties, but this is (entlast) entity and no necessary to select it - just change

2. Inspide of the fact this lisp can work with splines:

Code - Auto/Visual Lisp: [Select]
  1. (setq ent (car (AT:Entsel nil "\nSelect curve: " '("L" (0 . "ARC,LINE,SPLINE,LWPOLYLINE")) nil)))
  2.  
in this case lisp start to work not properly (return error on stage of creating closed polyline)

 

I can fix this error if I change this string..


Code - Auto/Visual Lisp: [Select]
  1.  
  2. (and (setq ent2 nil)
  3.  
  4.  

to this:

Code - Auto/Visual Lisp: [Select]
  1.  
  2. (and (setq ent (car (entsel "\nSelect curve: ")))
  3.  
  4.  

but in this case user need to select spline twice..

 

Is it possible to make some improvements in this combined routine?

Any help will be very appreciated