Help : closed polyline size etc.....

June 7

i need some help:(see attachment)

can't seem to get it to work like this who can help me

June 13

This should work, as long as the polylines keep to the same properties: 4 lines, 2 parallel long lines, ...


;; Deze functie gaat op zoek naar de onderste lange lijn van de vierhoek.
;; We gaan uit van 2 lange en 2 korte zijden.
;; en geeft als return  2 punter, links en rechts
(defun find_baseline (verts / a b dists dist_sorted l1 l2 mp)
	
	(setq dists (list))
	;;(setq b (last verts))
	(setq i 0)
	(foreach a verts
		(setq dist (distance 
				a 
				(setq b (nth (rem (+ i 1)(length verts)) verts)  )	;; this is the next vertex.  When a is the last vertex, the b will be vertex 0
		))
		(setq dists (append dists (list dist)))
		(setq i (+ i 1))
	)

	(setq dist_sorted (vl-sort-i dists '>))	
	(princ dists)
	(princ dist_sorted)
	
	(setq l1
		(list
			(nth (nth 0 dist_sorted) verts)
			(nth (rem (+ 1 (nth 0 dist_sorted)) (length verts)) verts) 
		)
	)
	(setq l2
		(list
			(nth (nth 1 dist_sorted) verts)
			(nth (rem (+ 1 (nth 1 dist_sorted)) (length verts)) verts) 
		)
	)
	
	;; now make sure point 1 is left, point 2 is right
	(if 
		(> (nth 0 (nth 0 l1)) (nth 0 (nth 1 l1))) 
		(setq l1 (list (nth 1 l1) (nth 0 l1)))
	)
	(if 
		(> (nth 0 (nth 0 l2)) (nth 0 (nth 1 l2))) 
		(setq l2 (list (nth 1 l2) (nth 0 l2)))
	)
	
	;; mid points
	(setq mp1 (mid-pt (nth 0 l1) (nth 1 l1)))
	(setq mp2 (mid-pt (nth 0 l2) (nth 1 l2)))
	;; return either L1 or L2, depending which is the bottom one
	(if 
		(< (nth 1 mp1) (nth 1 mp2))
		l1		
		l2		
	)
	
)

;; Returns the middle of two points
(defun mid-pt (p1 p2)
  (polar p1 (angle p1 p2) (/ (distance p1 p2) 2.0) )
)


(defun c:LHper (/ ssAll ss i ent entlist verts v1 v2 dist maxLen maxAng
                                 vecLine vecPerp unitVecLine unitVecPerp
                                 projValsLen projValsHt minLen maxLen minHt maxHt
                                 len height midpt lengthTxtPt heightTxtPt
                                 txtent1 txtent2 doc ms
								 bl mp1
								 )

  (vl-load-com)

  (setq doc (vla-get-ActiveDocument (vlax-get-Acad-Object)))
  (setq ms (vla-get-ModelSpace doc))
  
(command "_layer" "s" "epsT" "")
  
  ;; Selecteer alle polylines 
  (setq ssAll (ssget '((0 . "*POLYLINE")(8 . "eps"))))
  (if (not ssAll)
    (progn (princ "\nGeen polylines gevonden.") (exit))
  )

  ;; Filter gesloten polylines
  (setq ss (ssadd))
  (setq i 0)
  (while (< i (sslength ssAll))
    (setq ent (ssname ssAll i))
    (setq entlist (entget ent))
    (if (= 1 (cdr (assoc 70 entlist))) ; gesloten polyline
      (setq ss (ssadd ent ss))
    )
    (setq i (1+ i))
  )

  (if (= (sslength ss) 0)
    (progn (princ "\nGeen gesloten polylines gevonden.") (exit))
  )

  ;; Loop door elk gebied
  (repeat (sslength ss)
    (setq ent (ssname ss 0))
    (setq ss (ssdel ent ss))
	

    (setq entlist (entget ent))
    (setq verts '())
    (foreach d entlist
      (if (= (car d) 10)
        (setq verts (append verts (list (cdr d))))
      )
    )
	
	;; we zoeken de base line
	(setq bl (find_baseline verts))
	;;(drawLine (nth 0 bl) (nth 1 bl))
	

    ;; Bepaal langste zijde
    (setq maxLen 0)
    (setq maxAng 0)
    (setq v1 (car verts))
    (foreach v2 (cdr verts)
      (setq dist (distance v1 v2))
      (if (> dist maxLen)
        (progn
          (setq maxLen dist)
          (setq maxAng (angle v1 v2))
          (setq vecLine (list (- (car v2) (car v1)) (- (cadr v2) (cadr v1))))
        )
      )
      (setq v1 v2)
    )
    ;; Sluit laatste segment
    (setq v2 (car verts))
    (setq dist (distance v1 v2))
    (if (> dist maxLen)
      (progn
        (setq maxLen dist)
        (setq maxAng (angle v1 v2))
        (setq vecLine (list (- (car v2) (car v1)) (- (cadr v2) (cadr v1))))
      )
    )

    ;; vector haaks
    (setq vecPerp (list (- (cadr vecLine)) (car vecLine)))

    ;; unit vectors
    (setq lenVecLine (sqrt (+ (expt (car vecLine) 2) (expt (cadr vecLine) 2))))
    (setq unitVecLine (list (/ (car vecLine) lenVecLine) (/ (cadr vecLine) lenVecLine)))

    (setq lenVecPerp (sqrt (+ (expt (car vecPerp) 2) (expt (cadr vecPerp) 2))))
    (setq unitVecPerp (list (/ (car vecPerp) lenVecPerp) (/ (cadr vecPerp) lenVecPerp)))

    ;; projecteer vertices
    (setq projValsLen '() projValsHt '())
    (foreach v verts
      (setq vecV (list (- (car v) (car (car verts))) (- (cadr v) (cadr (car verts)))))
      (setq dotLen (+ (* (car vecV) (car unitVecLine)) (* (cadr vecV) (cadr unitVecLine))))
      (setq dotHt  (+ (* (car vecV) (car unitVecPerp)) (* (cadr vecV) (cadr unitVecPerp))))
      (setq projValsLen (cons dotLen projValsLen))
      (setq projValsHt (cons dotHt projValsHt))
    )

    
    ;; lengte en hoogte
    (setq len (- (apply 'max projValsLen) (apply 'min projValsLen)))
    (setq height (- (apply 'max projValsHt) (apply 'min projValsHt)))

    ;; middenpunt polyline
    (setq midpt (vlax-curve-getPointAtParam (vlax-ename->vla-object ent)
                  (/ (vlax-curve-getEndParam (vlax-ename->vla-object ent)) 2.0)))

    ;; tekstpunten
    (setq lengthTxtPt midpt)
    (setq heightTxtPt (list (+ (car midpt) (* (car unitVecPerp) 200))
                            (+ (cadr midpt) (* (cadr unitVecPerp) 200))
                            0))

	
	;; we plaatsen de tekst boven de baseline, in  het midden
	(setq mp1 (mid-pt (nth 0 bl) (nth 1 bl)))
	(setq ang1 (angle (nth 0 bl) (nth 1 bl)))
	;; tekst 130 units omhoog doen
	(setq mp1 (polar mp1 (+ ang1 (/ pi 2.0)) 130))
	
    ;; plaats lengte tekst
    (setq txtent1 (vla-addText ms (rtos len 2 2) (vlax-3d-point mp1) 175.0))
    (vla-put-Alignment txtent1 acAlignmentCenter)
    (vla-put-TextAlignmentPoint txtent1 (vlax-3d-point mp1))
    (vla-put-Rotation txtent1 ang1)

	;; tekst nog eens 200 units omhoog doen
	(setq mp1 (polar mp1 (+ ang1 (/ pi 2.0)) 200))


    ;; plaats hoogte tekst
    (setq txtent2 (vla-addText ms (rtos height 2 2) (vlax-3d-point mp1) 175.0))
    (vla-put-Alignment txtent2 acAlignmentCenter)
    (vla-put-TextAlignmentPoint txtent2 (vlax-3d-point mp1))
    (vla-put-Rotation txtent2 ang1)
  )

  (princ "\nLengte en hoogte geplaatst voor alle gebieden.")
  (princ)
)

I'm Belgian, I kept a couple remarks in Dutch

June 15

@Emmanuel Delay was working same thing. Almost finished just had to add text. for me I use this for mid point of a 4 side pline.

(setq mp (mapcar '* (mapcar '+ pt1 pt3) '(0.5 0.5)))

No Table of result ? That is what I did first. You can use this if you want.

(setvar 'ctablestyle "standard")
(Setq curspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))
(setq numrows 3)
(setq numcolumns 2)
(setq rowheight 530)
(setq colwidth 1600)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "Totals")
(vla-settext objtable 1 0 "Width")
(vla-Setrowheight Objtable  1 940)
(vla-settext objtable 1 1 "SOM\nLength")
(vla-SetTextStyle custObj (+ acDataRow acHeaderRow acTitleRow) "Standard")
(setq objtable (vlax-ename->vla-object (entlast)))
(vla-SetAlignment objtable (+ acDataRow acHeaderRow acTitleRow) acMiddleCenter)
(vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) 250)

maybe later today have to go now.

June 22

Give this a try

; https://www.cadtutor.net/forum/topic/98142-help-closed-polyline-size-etc/

(defun c:rectans ( / ang ang1 ang2 angpl co-ord colwidth objtable cp curspace custobj d1 d2 d3 d4
 lst lst2 lst3 vals mp num numcolumns numrows oldaunits oldsnap plent pt1 pt2 pt3 pt3 pt4 row rowheight ss tmp tot val x _groupby)

;; Make Readable  -  Lee Mac
;; Returns a given angle corrected for text readability
(defun lm:makereadable (a)
    ((lambda (a)
       (if (and (< (* pi 0.5) a) (<= a (* pi 1.5)))
	 (+ a pi)
	 a
       )
     )
      (rem (+ a pi pi) (+ pi pi))
    )
)

(defun M-Text (pt str angm)
 (entmakex (list (cons 0 "MTEXT")         
                 (cons 100 "AcDbEntity")
                 (cons 100 "AcDbMText")
                 (cons 10 pt)
				 (cons 50 angm)
                 (cons 1 str)
				 (cons 71 5)
			)
  )
)
				 

; groupby provided by Dexus

(defun _groupBy (fun lst0 / itm old rtn)
  (while lst0
    (setq itm (fun (car lst0))
          rtn
            (if (setq old (assoc itm rtn))
              (subst (cons itm (cons (car lst0) (cdr old))) old rtn)
              (cons (cons itm (list (car lst0))) rtn)
            )
          lst0 (cdr lst0))
  )
  rtn
)

(setq oldsnap (getvar 'osmode))
(setvar 'osmode 0)
(setq oldaunits (getvar 'aunits))
(setvar 'aunits 3)
(setvar 'textsize 175)

(setq ss (ssget '((0 . "LWPOLYLINE"))))

(setq lst '())
(repeat (setq x (sslength ss))
(setq plent (ssname ss (setq x (1- x))))
(setq co-ord (mapcar 'cdr (vl-remove-if-not '(lambda (x) (= (car x) 10)) (entget plent))))
(setq pt1 (nth 0 co-ord) pt2 (nth 1 co-ord) pt3 (nth 2 co-ord) pt4 (nth 3 co-ord))
(setq mp (mapcar '* (mapcar '+ pt1 pt3) '(0.5 0.5)))
(setq ang (abs (- (angle pt1 pt2)(angle pt2 pt3))))
(setq d1 (distance pt1 pt2))
(setq d2 (distance pt2 pt3))
(setq d3 (distance pt3 pt4))
(setq d4 (distance pt4 pt1))
(setq ang1 (angle pt1 pt2))
(setq ang2 (angle pt3 pt4))
(if (< d1 d3)
(setq d1 d3)
)
(if (< d2 d4)
  (setq d2 d4)
)
(if (> d1 d2)
 (progn
  (setq tmp d2)
  (setq d2 d1)
  (setq d1 tmp)
  (setq angpl (angle pt1 pt2))
 )
 (setq angpl (angle pt2 pt3))
)
(if (equal (/ pi 2) ang 0.00001)
  (princ)
  (setq d1 (abs (* (sin ang) d1)))
)
(setq lst (cons (list d1 d2) lst))
(setq angpl (lm:makereadable angpl))
(m-text mp (strcat (rtos d1 2 2) "\n" (rtos d2 2 2)) angpl)
)

(setq lst (vl-sort lst '(lambda (x y) (< (car x)(car y)))))

(setq lst2 (_groupBy   (lambda (e) (car e)) lst))

(setq lst3 '())
(foreach vals lst2
(if (= (length vals) 2)
  (setq lst3 (cons (list (rtos (abs (car vals)) 2 0)(rtos (abs (car  (cadr vals))) 2 0)) lst3))
  (progn
   (setq tot 0.0)
   (setq num (- (length vals) 1))
   (setq x 0)
   (repeat num
    (setq tot (+ tot (cadr (nth (setq x (1+ x)) vals))))
   )
   (setq lst3 (cons (list (rtos (car vals) 2 0)(rtos tot 2 2)) lst3))
  )
)
)

; make table 1600 wide x 2  533 row text 250

(setvar 'ctablestyle "standard")
(Setq curspace (vla-get-modelspace (vla-get-activedocument (vlax-get-acad-object))))
(setq pt1 (vlax-3d-point (getpoint "\nPick point for top left hand of table:  ")))

(setq numrows 3)
(setq numcolumns 2)
(setq rowheight 530)
(setq colwidth 1800)
(setq objtable (vla-addtable curspace pt1 numrows numcolumns rowheight colwidth))
(vla-settext objtable 0 0 "Totals")
(vla-settext objtable 1 0 "Width")
(vla-Setrowheight Objtable  1 940)
(vla-settext objtable 1 1 "SOM\nLength")
(vla-SetTextStyle Objtable (+ acDataRow acHeaderRow acTitleRow) "Standard")
(setq objtable (vlax-ename->vla-object (entlast)))
(vla-SetAlignment objtable (+ acDataRow acHeaderRow acTitleRow) acMiddleCenter)
(vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) 250)

(setq lst3 (vl-sort lst3 '(lambda (x y) (< (car x)(car y)))))
(setq row 2)
(setq x 0)
(repeat (length lst3)
  (vla-insertrows objtable row rowheight 1)
  (vla-settext objtable row 0 (car (nth x lst3)))
  (vla-settext objtable row 1 (cadr (nth x lst3)))
  (setq row (1+ row))
  (setq x (1+ x))
)
(vla-SetAlignment objtable (+ acDataRow acHeaderRow acTitleRow) acMiddleCenter)
(vla-SetTextHeight objtable (+ acDataRow acHeaderRow acTitleRow) 250)

(setvar 'osmode oldsnap)
(setvar 'aunits oldaunits)

(princ)
)

(C:rectans)

Sign In

Help : closed polyline size etc.....

Recommended Posts

wiebe

Emmanuel Delay

BIGAL

BIGAL

Join the conversation

Tutorials

Forums

Activity