Create the outline automatically by lisp
I don't really have an idea about how to do that, but I have some questions:
What determines which letter in an outline around the same letters is the one that stays in place? In the upper left corner, it's the upper one of two A's [blue-circled], but one position to the right and down, it's the lower one of two C's [yellow].
Shouldn't the red-circled segment, and one of the D's in the enclosed areas, be removed?
Does the difference in size of letters matter? In the row of 3 D's to the right of the A at the top, the one that stays, which is the larger size in the original, has become the smaller size [or, the smaller one in the right end of the area that stayed has also moved over].
In the drawing, there's a green shape wandering around among the letters. Is that relevant?
I hope this is what you are looking for.
; Modified from http://www.lee-mac.com/boxtext.html
(defun bt (off sel / *error* enx idx lst )
(repeat (setq idx (sslength sel))
(setq enx (entget (ssname sel (setq idx (1- idx))))
lst (cons (text-box-off enx (* off (cdr (assoc 40 enx)))) lst)
)
)
lst
)
;; Text Box - gile / Lee Mac
;; Returns an OCS point list describing a rectangular frame surrounding
;; the supplied text or mtext entity with optional offset
;; enx - [lst] Text or MText DXF data list
;; off - [rea] offset (may be zero)
(defun text-box-off ( enx off / bpt hgt jus lst ocs org rot wid )
(cond
( (= "TEXT" (cdr (assoc 00 enx)))
(setq bpt (cdr (assoc 10 enx))
rot (cdr (assoc 50 enx))
lst (textbox enx)
lst
(list
(list (- (caar lst) off) (- (cadar lst) off)) (list (+ (caadr lst) off) (- (cadar lst) off))
(list (+ (caadr lst) off) (+ (cadadr lst) off)) (list (- (caar lst) off) (+ (cadadr lst) off))
)
)
)
( (= "MTEXT" (cdr (assoc 00 enx)))
(setq ocs (cdr (assoc 210 enx))
bpt (trans (cdr (assoc 10 enx)) 0 ocs)
rot (angle '(0.0 0.0) (trans (cdr (assoc 11 enx)) 0 ocs))
wid (cdr (assoc 42 enx))
hgt (cdr (assoc 43 enx))
jus (cdr (assoc 71 enx))
org (list (cond ((member jus '(2 5 8)) (/ wid -2.0)) ((member jus '(3 6 9)) (- wid)) (0.0))
(cond ((member jus '(1 2 3)) (- hgt)) ((member jus '(4 5 6)) (/ hgt -2.0)) (0.0))
)
lst
(list
(list (- (car org) off) (- (cadr org) off)) (list (+ (car org) wid off) (- (cadr org) off))
(list (+ (car org) wid off) (+ (cadr org) hgt off)) (list (- (car org) off) (+ (cadr org) hgt off))
)
)
)
)
(if lst
( (lambda ( m ) (mapcar '(lambda ( p ) (mapcar '+ (mxv m p) bpt)) lst))
(list
(list (cos rot) (sin (- rot)) 0.0)
(list (sin rot) (cos rot) 0.0)
'(0.0 0.0 1.0)
)
)
)
)
;; Matrix x Vector - Vladimir Nesterovsky
;; Args: m - nxn matrix, v - vector in R^n
(defun mxv ( m v )
(mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
)
;; Convex Hull - Lee Mac
;; Implements the Graham Scan Algorithm to return the Convex Hull of a list of points.
(defun LM:ConvexHull ( lst / ch p0 )
(cond
( (< (length lst) 4) lst)
( (setq p0 (car lst))
(foreach p1 (cdr lst)
(if (or (< (cadr p1) (cadr p0))
(and (equal (cadr p1) (cadr p0) 1e-8) (< (car p1) (car p0)))
)
(setq p0 p1)
)
)
(setq lst
(vl-sort lst
(function
(lambda ( a b / c d )
(if (equal (setq c (angle p0 a)) (setq d (angle p0 b)) 1e-8)
(< (distance p0 a) (distance p0 b))
(< c d)
)
)
)
)
)
(setq ch (list (caddr lst) (cadr lst) (car lst)))
(foreach pt (cdddr lst)
(setq ch (cons pt ch))
(while (and (caddr ch) (LM:Clockwise-p (caddr ch) (cadr ch) pt))
(setq ch (cons pt (cddr ch)))
)
)
ch
)
)
)
;; Clockwise-p - Lee Mac
;; Returns T if p1,p2,p3 are clockwise oriented or collinear
(defun LM:Clockwise-p ( p1 p2 p3 )
(< (- (* (- (car p2) (car p1)) (- (cadr p3) (cadr p1)))
(* (- (cadr p2) (cadr p1)) (- (car p3) (car p1)))
)
1e-8
)
)
(defun point2d (pt) (list (car pt) (cadr pt)))
(defun mappend (fn lst) ; P. Norvig ??
(apply 'append (mapcar fn lst))
)
(defun mklist (x)
"If x is a list return it, otherwise return the list of x"
(if (listp x) x (list x)))
(defun flatten (exp)
;"Get rid of imbedded lists (to one level only)."
(mappend 'mklist exp))
(defun c:OBT ( / pts)
(setq pts (LM:ConvexHull (flatten (bt 0 (ssget "X" (list (cons 0 "*TEXT") (cons 1 (strcase (getstring "\nString value to create outline >")))))))))
(if pts
(progn
(command "_.pline")
(foreach pt pts (command pt))
(command "c")
)
)
(princ)
)
(princ "\nCommand OBT - creates convex hull around text elements")
(princ)
Command OBT create convex hull around set of edge point set consisting of textbox edges created for each
letter. For example letters D and E:
This is solution for a sample given in your dwg. If outlines around letters differ in size, as @Kent1Cooper asked in his post, then code would have to be modified.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@hak_vz wrote:
I hope this is what you are looking for.
....
We'd need to hear from the OP, but that doesn't look to me like what they want. The green shape in their sample drawing [if it's even relevant] is not at all of the character of the red shapes in your results, and your results don't show anything of the difference between the two sides of their original image, with multiple same letter "cells" combined, cell perimeters containing nothing removed completely, etc. @cwtwong, can you clarify?
Hello
I like the @john.uhden message :
>>> That's amazing. I would never even try to make something like that. I wonder what its purpose is <<<
I have an idea : it s an economic / optimization problem ! ... Use a minimum of letters / marks !?
THE HEALTH (Stay Safe), Regards, Patrice
If you are happy with my answer please mark "Accept as Solution" and if very happy please give me a Kudos (Felicitations) - Thanks
Patrice BRAUD
@Kent1Cooper I agree. Sample shown in image and the one in provided dwg are different, and we need OP to clarify his request and give us a way more details then he did in his request.
@marko_ribar I don't see this task meaningless. After second look at sample shown in his image sample, I guess what he wants to achieve is to select all fields with same later and join them together in patches. That can for example present parcels of land categorized according to variation of some property (value, ownership, contamination...). It can be basis for many statistical calculations.
I would rewrite this task as:
- create selection set of all text objects containing same letter.
- for each letter find its position and boundary defined by point (its position)
- if two or more boundaries share same same edge join them together
Let see what OP has to say.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@cwtwongHere is my solution. It create region objects. After you hide polylines in layer "0" and apply coloring
to individual regions you can get map as presented in image below. Modifying regions (explode, change layer .....) is left to you.
(defun c:OBT ( / cat ss i ssd pt *error*)
(defun *error* ()
(setvar 'cmdecho 1)
(princ)
)
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-startundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq categories (list "A" "B" "C" "D" "E" "F" "G" "H" ))
(setvar 'cmdecho 0)
(foreach cat categories
(setq ss (ssget "X" (list (cons 0 "*TEXT") (cons 1 cat))))
(if (and ss)
(progn
(setq i 0)
(setq ssd (ssadd))
(while
(< i (sslength ss))
(setq pt (cdr (assoc 10 (entget(ssname ss i)))))
(command "-boundary" pt "")
(command "region" (entlast) "")
(ssadd (entlast) ssd)
(setq i (+ i 1))
)
(command "union" ssd "")
)
)
)
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ "\nDone!")
(princ)
)
If this solves your request, accept this post as a solution. Minor changes possible.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@cwtwong wrote:Hi hak_vz, one more thing, Can the lisp shown one text if these are same value? Thanks!
Huh. This is really not easy to do. Commands REGION and UNION help us to join together individual areas and solution to your problem is easy. To accomplish what you want with text would ask for recreating boundaries, and some clever routines. I'll try to figure out possible solution, and hope some of participants may have something to add.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Hello @hak_vz
I am impressed by your beautiful Work & your Lisp (very short) !
THE HEALTH (Stay Safe), Regards, Patrice (The Old French EE Froggy)
If you are happy with my answer please mark "Accept as Solution" and if very happy please give me a Kudos (Felicitations) - Thanks
Patrice BRAUD
@cwtwong wrote:Hi hak_vz, one more thing, Can the lisp shown one text if these are same value? Thanks!
@cwtwong Here you have it! What you have to do is to arrange reminding text objects.
(defun c:OBT ( / cat ss ssd i j lines coords pt *error*)
(defun *error* ()
(setvar 'cmdecho 1)
(princ)
)
(defun getregionlines (region)
(setq ret (mapcar 'vlax-vla-object->ename (vlax-safearray->list(vlax-variant-value(vla-explode (vlax-ename->vla-object region))))))
(entdel region)
ret
)
(defun pointlist2d (lst / ret)(while lst (setq ret (cons (list (car lst)(cadr lst)) ret) lst (cddr lst))) (reverse ret))
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-startundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq categories (list "A" "B" "C" "D" "E" "F" "G" "H" ))
(setvar 'cmdecho 0)
(foreach cat categories
(setq ss (ssget "X" (list (cons 0 "*TEXT") (cons 1 cat))))
(if (and ss)
(progn
(setq i 0)
(setq ssd (ssadd))
(while
(< i (sslength ss))
(setq pt (cdr (assoc 10 (entget(ssname ss i)))))
(command "-boundary" pt "")
(command "region" (entlast) "")
(ssadd (entlast) ssd)
(setq i (+ i 1))
)
(command "union" ssd "")
(command "explode" (entlast))
(setq ss (ssget "X" '((0 . "REGION"))) i 0)
(while (< i (sslength ss))
(setq lines (getregionlines (ssname ss i)))
(setq ssd (ssadd))
(foreach line lines (setq ssd (ssadd line ssd)))
(command "_.pedit" "_multiple" ssd "" "" "_join" "" "")
(setq coords (pointlist2d (vlax-get (vlax-ename->vla-object (entlast)) 'coordinates)))
(setq coords (append coords (list(car coords))))
(setq ssd (ssget "_CP" coords '((0 . "*TEXT"))))
(if (and ssd (> (sslength ssd) 1))
(progn
(setq j (- (sslength ssd) 1))
(while (> j 0)
(entdel (ssname ssd j))
(setq j (- j 1))
)
)
)
(setq i (+ i 1))
)
)
)
)
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ "\nDone!")
(princ)
)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
Thanks @doaiena
@doaiena wrote:If there is only 1 letter of a given type, or all of the letters from the same type are neighbouring, you will have only a single region. When you explode that region, you will get lines, instead of individual regions, which will result in an error. I would suggest you put a check after the first explode, to see if the resulting entities are regions or lines.
In my code I create region for each field that contains only one letter, and command UNION joins all those regions together when applicable. First explode creates only region objects. Will make some more test, but didn't receive any error in my tests.
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
@cwtwong Here is final version of the code.
After some testing I've updated my code how @doaiena has suggested. In some special load configuration it won't delete redundant letters.
(defun c:OBT ( / cat ss ssd i j lines coords pt *error*)
(defun *error* ()
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ)
)
(defun getregionlines (region)
(setq ret (mapcar 'vlax-vla-object->ename (vlax-safearray->list(vlax-variant-value(vla-explode (vlax-ename->vla-object region))))))
(entdel region)
ret
)
(defun pointlist2d (lst / ret)(while lst (setq ret (cons (list (car lst)(cadr lst)) ret) lst (cddr lst))) (reverse ret))
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(vla-startundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setq categories (list "A" "B" "C" "D" "E" "F" "G" "H" ))
(setvar 'cmdecho 0)
(foreach cat categories
(setq ss (ssget "X" (list (cons 0 "*TEXT") (cons 1 cat))))
(if (and ss)
(progn
(setq ssd (ssadd) i 0)
(while
(< i (sslength ss))
(setq pt (cdr (assoc 10 (entget(ssname ss i)))))
(command "-boundary" pt "")
(command "region" (entlast) "")
(ssadd (entlast) ssd)
(setq i (+ i 1))
)
(command "union" ssd "")
(command "explode" (entlast))
(setq ss (ssget "X" '((0 . "REGION"))) i 0)
(while (and ss (< i (sslength ss)))
(setq lines (getregionlines (ssname ss i)))
(setq ssd (ssadd))
(foreach line lines (setq ssd (ssadd line ssd)))
(command "_.pedit" "_multiple" ssd "" "" "_join" "" "")
(setq coords (pointlist2d (vlax-get (vlax-ename->vla-object (entlast)) 'coordinates)))
(setq coords (append coords (list(car coords))))
(setq ssd (ssget "_CP" coords '((0 . "*TEXT"))))
(if (and ssd (> (sslength ssd) 1))
(progn
(setq j (- (sslength ssd) 1))
(while (> j 0)
(entdel (ssname ssd j))
(setq j (- j 1))
)
)
)
(setq i (+ i 1))
)
)
)
)
(vla-endundomark (vla-get-ActiveDocument (vlax-get-acad-object)))
(setvar 'cmdecho 1)
(princ "\nDone!")
(princ)
)
Miljenko Hatlak
Did your question get successfully answered? Then click on the ACCEPT SOLUTION button.
