Message 1 of 5
Combining routines issue...
- Mark as New
- Bookmark
- Subscribe
- Mute
- Subscribe to RSS Feed
- Permalink
- Report
Hi All.
This lisp can to draw ditch from polyline and hatch it inside with option to change hatch properties:
;;; Draw ditch from polyline and hatch it inside with option to change hatch properties
;;; Combined from existing routines with great respect to it authors by Igal Averbuh 2017
(defun c:dhe ( / *error* GetHatchNames Sel Ent EntData oData nStyle BasePt HatchList Pos
TogAngle tempList tempPt tempData )
(defun *error* ( msg )
(vl-bt)
(if oData (entmake oData))
(if Ent (entdel Ent))
(if msg (prompt (strcat "\n Error-> " msg)))
(redraw)
)
;--------------------------------
(defun GetHatchNames ( filePath / Opened tempStr tempPos tempName HatchList )
(if (setq Opened (open filePath "r"))
(while (setq tempStr (read-line Opened))
(if
(and
(= (substr tempStr 1 1) "*")
(setq tempPos (vl-string-search "," tempStr))
(setq tempName (substr tempStr 2 (1- tempPos)))
(/= (strcase tempName) "SOLID")
)
(setq HatchList (cons tempName HatchList))
)
)
)
(if Opened (close Opened))
(reverse HatchList)
)
;------------------------------------
(if
(and
(setq Sel (entsel "\n Select hatch to edit dynamicly: "))
(setq oData (entget (car Sel)))
(= (cdr (assoc 0 oData)) "HATCH")
(setq nStyle (cdr (assoc 2 oData)))
(setq BasePt (cadr Sel))
(setq HatchList (GetHatchNames (findfile "acad.pat")))
(setq Pos (vl-position nStyle HatchList))
(setq TogAngle 0)
)
(while
(and
(not
(prompt
(strcat
"\r Current style: "
nStyle
" , Allow angle change: "
(if (zerop TogAngle) "No" "Yes")
" [Style / Angle toggle]: "
)
)
)
(setq tempList (grread T 11))
(not (equal (car tempList) 3))
)
(or
Ent
(setq Ent (car Sel))
)
(setq EntData (entget Ent '("*")))
(cond
( (equal (car tempList) 5)
(setq tempPt (cadr tempList))
(redraw)
(grdraw BasePt tempPt 7)
(setq tempData
(subst
(cons
41
(distance tempPt BasePt)
;(/ (distance tempPt BasePt) (/ (getvar 'ViewSize) 5.))
)
(assoc 41 EntData)
EntData
)
)
(if (equal TogAngle 1)
(setq tempData
(subst
(cons 52 (angle BasePt tempPt))
(assoc 52 EntData)
tempData
)
)
)
(if (entmake tempData)
(progn
(entdel Ent)
(setq Ent (entlast))
)
)
)
((equal (car tempList) 2)
(cond
( (member (cadr tempList) '(83 115))
(setq nStyle (nth (setq Pos (1+ Pos)) HatchList))
(if (entmake
(subst
(cons 2 nStyle)
(assoc 2 EntData)
EntData
)
)
(progn
(entdel Ent)
(setq Ent (entlast))
)
)
)
( (member (cadr tempList) '(65 97))
(setq TogAngle (abs (1- TogAngle)))
)
)
)
)
)
)
(redraw)
(princ)
)
(defun c:tl2 (/ AT:Offset ent pnt lst)
;; Offset selected curve and connect each end (also option to convert to LWPolyline).
;; Copyright© Alan J. Thompson, 04.29.10
(setvar "cmdecho" 0)
(defun OC1 (/ AT:Offset ent pnt lst)
;; Offset selected curve and connect each end (also option to convert to LWPolyline).
;; Copyright© Alan J. Thompson, 04.29.10
(defun AT:Offset (O D P / _pt p1 p2 c D g)
;; Offset selected object
;; O - Object to offset
;; D - Distance to offset object
;; P - Point on side of object to offset
;; Alan J. Thompson, 09.12.09 / 03.25.10
(setq _pt (lambda (s)
(vlax-curve-getPointAtDist O (s (vlax-curve-getDistAtPoint O p1) 0.00001))
)
)
(if (and (setq p1 (vlax-curve-getclosestpointtoprojection O (trans P 1 0) '(0 0 1)))
(or (setq p2 (setq c (_pt +))) (setq p2 (_pt -)))
(if (minusp (- (* (- (car p2) (car p1)) (- (cadr (trans P 1 0)) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car (trans P 1 0)) (car p1)))
)
)
(if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
(setq D (- (abs D)))
(setq D (abs D))
)
(if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
(setq D (abs D))
(setq D (- (abs D)))
)
)
(or c (setq D (- D)))
(not (vl-catch-all-error-p (setq g (vl-catch-all-apply 'vla-offset (list O D)))))
)
(car (vlax-safearray->list (vlax-variant-value g)))
)
)
(and (minusp (getvar 'offsetdist)) (setvar 'offsetdist 1.))
(cond
((and
(if AT:Entsel
(setq ent (car (AT:Entsel nil "\nSelect curve: " '("L" (0 . "ARC,LINE,SPLINE,LWPOLYLINE")) nil)))
(and (setq ent2 nil)
(command "pedit" "l" "" "" )
(or (vl-position (cdr (assoc 0 (entget ent))) '("ARC" "LINE" "SPLINE" "LWPOLYLINE"))
(alert "Invalid object!")
)
)
)
(not (initget 6))
(setvar
'offsetdist
(cond
((getdist (strcat "\nSpecify offset distance or <" (rtos (getvar 'offsetdist)) ">: ")))
((getvar 'offsetdist))
)
)
(setq pnt (getpoint "\nSpecify point on side to offset: "))
((lambda (off)
(if off
(setq lst (list ent (vlax-vla-object->ename off)))
(alert "Cannot offset side of curve!")
)
)
(AT:Offset (vlax-ename->vla-object ent) (getvar 'offsetdist) pnt)
)
)
(or (vlax-curve-isClosed (car lst))
(setq lst (append
(mapcar
(function
(lambda (a b f)
(entmakex
(list '(0 . "LINE")
(assoc 8 (entget ent))
(cons 10 (f a))
(cons 11 (f b))
)
)
)
)
lst
(reverse lst)
(list vlax-curve-getStartPoint vlax-curve-getEndPoint)
)
lst
)
)
)
(initget 0 "Yes No")
(if (and (> (length lst) 2)
(eq "Yes"
(cond ((getkword "\nConvert to closed LWPolyline? [Yes/No] <Yes>: "))
("Yes")
)
)
)
((lambda (ss)
(if (zerop (getvar 'peditaccept))
(vl-cmdf "_.pedit" "_m" ss "" "_y" "_j" "" "")
(vl-cmdf "_.pedit" "_m" ss "" "_j" "" "")
)
)
((lambda (l s) (foreach x l (ssadd x s))) lst (ssadd))
)
)
)
)
(princ)
)
(oc1)
(defun AT:Offset (O D P / _pt p1 p2 c D g)
;; Offset selected object
;; O - Object to offset
;; D - Distance to offset object
;; P - Point on side of object to offset
;; Alan J. Thompson, 09.12.09 / 03.25.10
(setq _pt (lambda (s)
(vlax-curve-getPointAtDist O (s (vlax-curve-getDistAtPoint O p1) 0.00001))
)
)
(if (and (setq p1 (vlax-curve-getclosestpointtoprojection O (trans P 1 0) '(0 0 1)))
(or (setq p2 (setq c (_pt +))) (setq p2 (_pt -)))
(if (minusp (- (* (- (car p2) (car p1)) (- (cadr (trans P 1 0)) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car (trans P 1 0)) (car p1)))
)
)
(if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
(setq D (- (abs D)))
(setq D (abs D))
)
(if (vl-position (vla-get-objectname O) '("AcDbLine" "AcDbXline"))
(setq D (abs D))
(setq D (- (abs D)))
)
)
(or c (setq D (- D)))
(not (vl-catch-all-error-p (setq g (vl-catch-all-apply 'vla-offset (list O D)))))
)
(car (vlax-safearray->list (vlax-variant-value g)))
)
)
(and (minusp (getvar 'offsetdist)) (setvar 'offsetdist 1.))
(cond
((and
(if AT:Entsel
(setq ent (car (AT:Entsel nil "\nSelect curve: " '("L" (0 . "ARC,LINE,SPLINE,LWPOLYLINE")) nil)))
(and (setq ent (car (entsel "\nSelect curve: ")))
(or (vl-position (cdr (assoc 0 (entget ent))) '("ARC" "LINE" "SPLINE" "LWPOLYLINE"))
(alert "Invalid object!")
)
)
)
(not (initget 6))
(setvar
'offsetdist
(cond
((getdist (strcat "\nSpecify offset distance or <" (rtos (getvar 'offsetdist)) ">: ")))
((getvar 'offsetdist))
)
)
(setq pnt (getpoint "\nSpecify point on side to offset: "))
((lambda (off)
(if off
(setq lst (list ent (vlax-vla-object->ename off)))
(alert "Cannot offset side of curve!")
)
)
(AT:Offset (vlax-ename->vla-object ent) (getvar 'offsetdist) pnt)
)
)
(or (vlax-curve-isClosed (car lst))
(setq lst (append
(mapcar
(function
(lambda (a b f)
(entmakex
(list '(0 . "LINE")
(assoc 8 (entget ent))
(cons 10 (f a))
(cons 11 (f b))
)
)
)
)
lst
(reverse lst)
(list vlax-curve-getStartPoint vlax-curve-getEndPoint)
)
lst
)
)
)
(initget 0 "Yes No")
(if (and (> (length lst) 2)
(eq "Yes"
(cond ((getkword "\nConvert to closed LWPolyline? [Yes/No] <Yes>: "))
("Yes")
)
)
)
((lambda (ss)
(if (zerop (getvar 'peditaccept))
(vl-cmdf "_.pedit" "_m" ss "" "_y" "_j" "" "")
(vl-cmdf "_.pedit" "_m" ss "" "_j" "" "")
)
(command "-hatch" "s" ss "" "p" "ANSI37" "5" "45" "")
)
((lambda (l s) (foreach x l (ssadd x s))) lst (ssadd))
)
)
)
)
(princ)
(setvar "cmdecho" 1)
)
(defun c:tl ()
(c:tl2)
(c:dhe)
)
(c:tl)
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:
(setq ent (car (AT:Entsel nil "\nSelect curve: " '("L" (0 . "ARC,LINE,SPLINE,LWPOLYLINE")) nil)))
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..
(and (setq ent2 nil)
to this:
(and (setq ent (car (entsel "\nSelect curve: ")))
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
