Engineer_Yasser Posted May 27 Posted May 27 (edited) I need help to add ( Slope Arrow - Length - Slope ) for Selected polylines Test.dwg Edited May 28 by Engineer_Yasser Quote
exceed Posted May 28 Posted May 28 (edited) ; slope - 2024.05.28 exceed (defun c:SLOPE ( / acdoc mspace fuzz ssp sspl i ptlist ent entlist pt ss ssl obj coordlist coordlistlen p1 p2 xydist midpt parameter totallen midlen j p1z p2z flag1 flag2 pt2 sloperatio slopeblock blkang slopetextpt slopetext lengthtextpt lengthtext midparam prevparam nextparam) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) (setq mspace (vla-get-modelspace acdoc)) (setq fuzz 0.005) (setq ssp (ssget "X" '((0 . "POINT")))) (setq sspl (sslength ssp)) (setq i 0) (setq ptlist '()) (repeat sspl (setq ent (ssname ssp i)) (setq entlist (entget ent)) (setq pt (cdr (assoc 10 entlist))) (setq ptlist (cons pt ptlist)) (setq i (+ i 1)) ) ;(princ "\n pt list - ") ;(princ ptlist) (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "-Polyline-")))) (setq ssl (sslength ss)) (setq i 0) (repeat ssl (setq ent (ssname ss i)) (setq obj (vlax-ename->vla-object ent)) (setq coordlist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq coordlistlen (length coordlist)) (setq p1 (list (car coordlist) (cadr coordlist) 0)) (setq p2 (list (nth (- coordlistlen 2) coordlist) (nth (- coordlistlen 1) coordlist) 0)) (setq xydist (distance p1 p2)) (setq midpt '()) (setq param (vlax-curve-getEndParam obj)) (setq totallen (vlax-curve-getDistAtParam obj param)) (setq midlen (* 0.5 totallen)) (setq midpt (vlax-curve-getPointAtDist obj midlen)) ;(setq midparam (vlax-curve-getParamAtPoint obj (vlax-curve-getClosestPointTo obj midpt))) ;(setq prevparam (vlax-curve-getPointAtParam obj (fix midparam))) (setq prevparam (vlax-curve-getpointatdist obj (* 0.499999 totallen))) ;(setq nextparam (vlax-curve-getPointAtParam obj (+ (fix midparam) 1))) (setq nextparam (vlax-curve-getpointatdist obj (* 0.500001 totallen))) ;(princ midpt) (setq j 0) (setq p1z 0) (setq p2z 0) (setq flag1 0) (setq flag2 0) (repeat sspl (setq pt2 (nth j ptlist)) (if (and (and (< (- (car p1) fuzz) (car pt2)) (< (car pt2) (+ (car p1) fuzz))) (and (< (- (car p1) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p1) fuzz))) (= flag1 0) ) (progn (setq p1z (caddr pt2)) ;(princ "\n p1z = ") ;(princ p1z) (setq flag1 1) ) ) (if (and (and (< (- (car p2) fuzz) (car pt2)) (< (car pt2) (+ (car p2) fuzz))) (and (< (- (car p2) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p2) fuzz))) (= flag2 0) (= flag1 1) ) (progn (setq p2z (caddr pt2)) ;(princ "\n p2z = ") ;(princ p2z) (setq flag2 1) ) ) (setq j (+ j 1)) ) (if (and (= flag1 1) (= flag2 1)) (progn (setq p1 (list (car p1) (cadr p1) p1z)) (setq p2 (list (car p2) (cadr p2) p2z)) (setq sloperatio (* 100 (/ (abs (- p1z p2z)) xydist))) ;(setq midpt (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2))) (if (> p1z p2z) ;(setq blkang (angle p1 p2)) (setq blkang (angle prevparam nextparam)) ;(setq blkang (angle p2 p1)) (setq blkang (angle nextparam prevparam)) ) ;(princ "\n sloperatio - ") ;(princ sloperatio) ;(princ "%") (setq slopeblock (vla-InsertBlock mspace (vlax-3d-point midpt) "-Slope-" 5 5 5 blkang)) (cond ((and (<= 0 blkang) (< blkang (/ pi 2))) ;(princ "a") ) ((and (<= (/ pi 2) blkang) (< blkang pi)) ;(princ "b") (setq blkang (- blkang pi)) ) ((and (<= pi blkang) (< blkang (* 1.5 pi))) ;(princ "c") (setq blkang (- blkang pi)) ) ((and (<= (* 1.5 pi) blkang) (< blkang pi)) ;(princ "d") ) ) (setq slopetextpt (polar midpt (+ blkang (* 0.5 pi)) 5)) (setq slopetext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 100 "AcDbText") (cons 10 slopetextpt) (cons 11 slopetextpt) (cons 40 5) (cons 1 (strcat (rtos sloperatio 2 2) "%")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) (setq lengthtextpt (polar midpt (- blkang (* 0.5 pi)) 10)) (setq lengthtext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 62 7) (cons 100 "AcDbText") (cons 10 lengthtextpt) (cons 11 lengthtextpt) (cons 40 5) (cons 1 (strcat (rtos xydist 2 2) "m")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "-Elevation-") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) ) (progn ;(princ "\n there's no elevation point for this polyline") ) ) (setq i (+ i 1)) ) (princ) ) If the polyline bends sharply, the angle of the arrow and text may be strange. p.s - Is it correct to use the horizontal length rather than the inclined length? edit - angle problem in the gif has been corrected some Edited May 28 by exceed 4 1 Quote
Engineer_Yasser Posted May 28 Author Posted May 28 3 hours ago, exceed said: ; slope - 2024.05.28 exceed (defun c:SLOPE ( / acdoc mspace fuzz ssp sspl i ptlist ent entlist pt ss ssl obj coordlist coordlistlen p1 p2 xydist midpt parameter totallen midlen j p1z p2z flag1 flag2 pt2 sloperatio slopeblock blkang slopetextpt slopetext lengthtextpt lengthtext midparam prevparam nextparam) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) (setq mspace (vla-get-modelspace acdoc)) (setq fuzz 0.005) (setq ssp (ssget "X" '((0 . "POINT")))) (setq sspl (sslength ssp)) (setq i 0) (setq ptlist '()) (repeat sspl (setq ent (ssname ssp i)) (setq entlist (entget ent)) (setq pt (cdr (assoc 10 entlist))) (setq ptlist (cons pt ptlist)) (setq i (+ i 1)) ) ;(princ "\n pt list - ") ;(princ ptlist) (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "-Polyline-")))) (setq ssl (sslength ss)) (setq i 0) (repeat ssl (setq ent (ssname ss i)) (setq obj (vlax-ename->vla-object ent)) (setq coordlist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq coordlistlen (length coordlist)) (setq p1 (list (car coordlist) (cadr coordlist) 0)) (setq p2 (list (nth (- coordlistlen 2) coordlist) (nth (- coordlistlen 1) coordlist) 0)) (setq xydist (distance p1 p2)) (setq midpt '()) (setq param (vlax-curve-getEndParam obj)) (setq totallen (vlax-curve-getDistAtParam obj param)) (setq midlen (* 0.5 totallen)) (setq midpt (vlax-curve-getPointAtDist obj midlen)) ;(setq midparam (vlax-curve-getParamAtPoint obj (vlax-curve-getClosestPointTo obj midpt))) ;(setq prevparam (vlax-curve-getPointAtParam obj (fix midparam))) (setq prevparam (vlax-curve-getpointatdist obj (* 0.499999 totallen))) ;(setq nextparam (vlax-curve-getPointAtParam obj (+ (fix midparam) 1))) (setq nextparam (vlax-curve-getpointatdist obj (* 0.500001 totallen))) ;(princ midpt) (setq j 0) (setq p1z 0) (setq p2z 0) (setq flag1 0) (setq flag2 0) (repeat sspl (setq pt2 (nth j ptlist)) (if (and (and (< (- (car p1) fuzz) (car pt2)) (< (car pt2) (+ (car p1) fuzz))) (and (< (- (car p1) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p1) fuzz))) (= flag1 0) ) (progn (setq p1z (caddr pt2)) ;(princ "\n p1z = ") ;(princ p1z) (setq flag1 1) ) ) (if (and (and (< (- (car p2) fuzz) (car pt2)) (< (car pt2) (+ (car p2) fuzz))) (and (< (- (car p2) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p2) fuzz))) (= flag2 0) (= flag1 1) ) (progn (setq p2z (caddr pt2)) ;(princ "\n p2z = ") ;(princ p2z) (setq flag2 1) ) ) (setq j (+ j 1)) ) (if (and (= flag1 1) (= flag2 1)) (progn (setq p1 (list (car p1) (cadr p1) p1z)) (setq p2 (list (car p2) (cadr p2) p2z)) (setq sloperatio (* 100 (/ (abs (- p1z p2z)) xydist))) ;(setq midpt (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2))) (if (> p1z p2z) ;(setq blkang (angle p1 p2)) (setq blkang (angle prevparam nextparam)) ;(setq blkang (angle p2 p1)) (setq blkang (angle nextparam prevparam)) ) ;(princ "\n sloperatio - ") ;(princ sloperatio) ;(princ "%") (setq slopeblock (vla-InsertBlock mspace (vlax-3d-point midpt) "-Slope-" 5 5 5 blkang)) (cond ((and (<= 0 blkang) (< blkang (/ pi 2))) ;(princ "a") ) ((and (<= (/ pi 2) blkang) (< blkang pi)) ;(princ "b") (setq blkang (- blkang pi)) ) ((and (<= pi blkang) (< blkang (* 1.5 pi))) ;(princ "c") (setq blkang (- blkang pi)) ) ((and (<= (* 1.5 pi) blkang) (< blkang pi)) ;(princ "d") ) ) (setq slopetextpt (polar midpt (+ blkang (* 0.5 pi)) 5)) (setq slopetext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 100 "AcDbText") (cons 10 slopetextpt) (cons 11 slopetextpt) (cons 40 5) (cons 1 (strcat (rtos sloperatio 2 2) "%")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) (setq lengthtextpt (polar midpt (- blkang (* 0.5 pi)) 10)) (setq lengthtext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 62 7) (cons 100 "AcDbText") (cons 10 lengthtextpt) (cons 11 lengthtextpt) (cons 40 5) (cons 1 (strcat (rtos xydist 2 2) "m")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "-Elevation-") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) ) (progn ;(princ "\n there's no elevation point for this polyline") ) ) (setq i (+ i 1)) ) (princ) ) If the polyline bends sharply, the angle of the arrow and text may be strange. p.s - Is it correct to use the horizontal length rather than the inclined length? edit - angle problem in the gif has been corrected some Woow really brilliant .. Thanks, a lot It's super fast also 1 Quote
Steven P Posted May 28 Posted May 28 9 hours ago, exceed said: ; slope - 2024.05.28 exceed (defun c:SLOPE ( / acdoc mspace fuzz ssp sspl i ptlist ent entlist pt ss ssl obj coordlist coordlistlen p1 p2 xydist midpt parameter totallen midlen j p1z p2z flag1 flag2 pt2 sloperatio slopeblock blkang slopetextpt slopetext lengthtextpt lengthtext midparam prevparam nextparam) (setq acdoc (vla-get-activedocument (vlax-get-acad-object))) (setq mspace (vla-get-modelspace acdoc)) (setq fuzz 0.005) (setq ssp (ssget "X" '((0 . "POINT")))) (setq sspl (sslength ssp)) (setq i 0) (setq ptlist '()) (repeat sspl (setq ent (ssname ssp i)) (setq entlist (entget ent)) (setq pt (cdr (assoc 10 entlist))) (setq ptlist (cons pt ptlist)) (setq i (+ i 1)) ) ;(princ "\n pt list - ") ;(princ ptlist) (setq ss (ssget '((0 . "LWPOLYLINE") (8 . "-Polyline-")))) (setq ssl (sslength ss)) (setq i 0) (repeat ssl (setq ent (ssname ss i)) (setq obj (vlax-ename->vla-object ent)) (setq coordlist (vlax-safearray->list (vlax-variant-value (vlax-get-property obj 'coordinates)))) (setq coordlistlen (length coordlist)) (setq p1 (list (car coordlist) (cadr coordlist) 0)) (setq p2 (list (nth (- coordlistlen 2) coordlist) (nth (- coordlistlen 1) coordlist) 0)) (setq xydist (distance p1 p2)) (setq midpt '()) (setq param (vlax-curve-getEndParam obj)) (setq totallen (vlax-curve-getDistAtParam obj param)) (setq midlen (* 0.5 totallen)) (setq midpt (vlax-curve-getPointAtDist obj midlen)) ;(setq midparam (vlax-curve-getParamAtPoint obj (vlax-curve-getClosestPointTo obj midpt))) ;(setq prevparam (vlax-curve-getPointAtParam obj (fix midparam))) (setq prevparam (vlax-curve-getpointatdist obj (* 0.499999 totallen))) ;(setq nextparam (vlax-curve-getPointAtParam obj (+ (fix midparam) 1))) (setq nextparam (vlax-curve-getpointatdist obj (* 0.500001 totallen))) ;(princ midpt) (setq j 0) (setq p1z 0) (setq p2z 0) (setq flag1 0) (setq flag2 0) (repeat sspl (setq pt2 (nth j ptlist)) (if (and (and (< (- (car p1) fuzz) (car pt2)) (< (car pt2) (+ (car p1) fuzz))) (and (< (- (car p1) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p1) fuzz))) (= flag1 0) ) (progn (setq p1z (caddr pt2)) ;(princ "\n p1z = ") ;(princ p1z) (setq flag1 1) ) ) (if (and (and (< (- (car p2) fuzz) (car pt2)) (< (car pt2) (+ (car p2) fuzz))) (and (< (- (car p2) fuzz) (car pt2)) (< (cadr pt2) (+ (cadr p2) fuzz))) (= flag2 0) (= flag1 1) ) (progn (setq p2z (caddr pt2)) ;(princ "\n p2z = ") ;(princ p2z) (setq flag2 1) ) ) (setq j (+ j 1)) ) (if (and (= flag1 1) (= flag2 1)) (progn (setq p1 (list (car p1) (cadr p1) p1z)) (setq p2 (list (car p2) (cadr p2) p2z)) (setq sloperatio (* 100 (/ (abs (- p1z p2z)) xydist))) ;(setq midpt (list (/ (+ (car p1) (car p2)) 2) (/ (+ (cadr p1) (cadr p2)) 2) (/ (+ (caddr p1) (caddr p2)) 2))) (if (> p1z p2z) ;(setq blkang (angle p1 p2)) (setq blkang (angle prevparam nextparam)) ;(setq blkang (angle p2 p1)) (setq blkang (angle nextparam prevparam)) ) ;(princ "\n sloperatio - ") ;(princ sloperatio) ;(princ "%") (setq slopeblock (vla-InsertBlock mspace (vlax-3d-point midpt) "-Slope-" 5 5 5 blkang)) (cond ((and (<= 0 blkang) (< blkang (/ pi 2))) ;(princ "a") ) ((and (<= (/ pi 2) blkang) (< blkang pi)) ;(princ "b") (setq blkang (- blkang pi)) ) ((and (<= pi blkang) (< blkang (* 1.5 pi))) ;(princ "c") (setq blkang (- blkang pi)) ) ((and (<= (* 1.5 pi) blkang) (< blkang pi)) ;(princ "d") ) ) (setq slopetextpt (polar midpt (+ blkang (* 0.5 pi)) 5)) (setq slopetext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 100 "AcDbText") (cons 10 slopetextpt) (cons 11 slopetextpt) (cons 40 5) (cons 1 (strcat (rtos sloperatio 2 2) "%")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "Standard") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) (setq lengthtextpt (polar midpt (- blkang (* 0.5 pi)) 10)) (setq lengthtext (entmakex (list (cons 0 "TEXT") (cons 100 "AcDbEntity") (cons 8 "-Label Between Geometry Points") (cons 67 0) (cons 62 7) (cons 100 "AcDbText") (cons 10 lengthtextpt) (cons 11 lengthtextpt) (cons 40 5) (cons 1 (strcat (rtos xydist 2 2) "m")) (cons 50 blkang) (cons 41 1) (cons 51 0) (cons 7 "-Elevation-") (cons 71 0) (cons 72 1) (cons 100 "AcDbText") (cons 73 0) ) ) ) ) (progn ;(princ "\n there's no elevation point for this polyline") ) ) (setq i (+ i 1)) ) (princ) ) If the polyline bends sharply, the angle of the arrow and text may be strange. p.s - Is it correct to use the horizontal length rather than the inclined length? edit - angle problem in the gif has been corrected some That's really nice, 1 Quote
Steven P Posted May 28 Posted May 28 only way I can think to get the angles right is to draw the arrow as a polyline not a polyline in a block and then match the bulge to the line underneath.... but not sure if that is worth the time investment for the number of arrows it would fix 1 Quote
Recommended Posts
Join the conversation
You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.