Leaderboard

The following program will accurately determine the fold angles and then rotate the two objects so that they meet at a common seam. The user must specify the followinng points. The folding axis for polyline A is a line passing through the corner point and fold line point A. Likewise, the folding axis for polyline B is the line passing through the corner point and the fold line point B. The seams are defined with points A and B. The two polylines must lie on the world XY plane to start. After execution the polylines are rotated about their axes so that the seams are collinear. (defun c:fold (/ pAB pA1 Pb1 pA2 pB2 d pA3 dABA2 pB3 pInters rA rB Az Bz pA4 pB4 thetrA thetrB thetaA thetaB) ; calculates the fold angle for two objects. ; The object must lie on the world XY plane. ; L. Minardi 2/15/2024 (setq pAB (getpoint "\nEnter point at corner of poly A and B.") pA1 (getpoint pAB "\nEnter point on fold line of poly A.") pB1 (getpoint pAB "\nEnter point on fold line of poly B.") pA2 (getpoint pAB "\nEnter point on poly A at seam.") pB2 (getpoint pAB "\nEnter point on poly B at seam.") d (vxv (mapcar '- pA2 pA1) (vx1 (mapcar '- pAB pA1))) pa3 (mapcar '+ ; projection of pA2 to axis A (mapcar '* (vx1 (mapcar '- pAB pA1)) (list d d d) ) pA1 ) dABA2 (distance pAB pA2) ; distance along seam AB to A2 pB2 (mapcar '+ ; adjust pB2 to be same distance along seam pAB (mapcar '* (vx1 (mapcar '- pB2 pAB)) (list dABA2 dABA2 dABA2) ) ) d (vxv (mapcar '- pB2 pB1) (vx1 (mapcar '- pAB pB1))) pb3 (mapcar '+ ; projection of pB2 to axis B (mapcar '* (vx1 (mapcar '- pAB pB1)) (list d d d) ) pB1 ) pInters (inters pA2 pA3 pB2 pB3) ; intersection of two planes rA (distance pA2 pA3) ; radius A rB (distance pB2 pB3) ; radius B Az (sqrt ; z coordnate for rotated pA2 (- (expt ra 2) (expt (distance pInters pA3) 2) ) ) pA4 (list (car pInters) (cadr pInters) Az) ; final location for pA2 thetrA ; rotation angle in radians for poly A (acos (vxv (vx1 (mapcar '- pInters pA3)) (vx1 (mapcar '- pA4 pA3)) ) ) thetaA (/ (* thetrA 180.) pi) ) (princ "\ntheta A = ") (princ thetaA) (setq Bz (sqrt ; z coordinate for rotated pB2 (- (expt rB 2) (expt (distance pInters pB3) 2) ) ) ) (setq pB4 (list (car pInters) (cadr pInters) Bz)) (setq thetrB ; rotation angle in radians for poly B (acos (vxv (vx1 (mapcar '- pInters pB3)) (vx1 (mapcar '- pB4 pB3)) ) ) ) (setq thetaB (/ (* thetrB 180.) pi)) (princ "\ntheta B = ") (princ thetaB) ;(setq polyA (car (entsel "\nSelect polyline A"))) ;(setq polyB (car (entsel "\nSelect polyline B"))) ;(command "_rotate3d" polyA "" "2" pA1 pAB thetaA) ;(command "_rotate3d" polyB "" "2" pAB pB1 thetaB) (rotatepoly) (princ) ) (defun rotatepoly (/) (setq polyA (car (entsel "\nSelect polyline A")) polyB (car (entsel "\nSelect polyline B")) ) (command "_rotate3d" polyA "" "2" pA1 pAB thetaA) (command "_rotate3d" polyB "" "2" pAB pB1 thetaB) (princ) ) ;; ArcCosine - Lee Mac ;; Args: -1 <= x <= 1 (defun acos ( x ) (if (<= -1.0 x 1.0) (atan (sqrt (- 1.0 (* x x))) x) ) ) ;; Tangent - Lee Mac ;; Args: x - real (defun tan ( x ) (if (not (equal 0.0 (cos x) 1e-10)) (/ (sin x) (cos x)) ) ) ;; Vector Dot Product - Lee Mac ;; Args: u,v - vectors in R^n (defun vxv ( u v ) (apply '+ (mapcar '* u v)) ) ;; Vector Cross Product - Lee Mac ;; Args: u,v - vectors in R^3 (defun v^v ( u v ) (list (- (* (cadr u) (caddr v)) (* (cadr v) (caddr u))) (- (* (car v) (caddr u)) (* (car u) (caddr v))) (- (* (car u) (cadr v)) (* (car v) (cadr u))) ) ) ;; Unit Vector - Lee Mac ;; Args: v - vector in R^2 or R^3 (defun vx1 ( v ) ( (lambda ( n ) (if (equal 0.0 n 1e-10) nil (mapcar '/ v (list n n n)))) (distance '(0.0 0.0 0.0) v) ) )

I hope so...

Can you post or reference the LISP you use now? If that does what you need on each drawing, sounds like you just need to run it in a batch routine, is that correct?

Thanks for the feedback, I am glad to help! It is not big deal to change the Lisp, but I will let you to walk alone that route. The program sorts the texts descending by their values, it removes the first one from the sorted list and it deletes from the drawing the remaining ones. Just sort them ascending to keep only the smallest one. The sort is performed by the (vl-sort...). So in that line, change in the lambda function the ">" sign with "<" and you are done. Also you can change the program to manipulate blocks. First of all, at the beginning, instruct the ssget to search for blocks (inserts) instead of texts. Replace "*TEXT" with "INSERT". Next, change the lambda function. Replace the whole line with this one: (setq lst (cdr (vl-sort lst '(lambda (a b) (> (cadddr (assoc 10 (entget a))) (cadddr (assoc 10 (entget b)))))))) It should work...

fuccaro, thank you so much. That code works perfectly. You asked about what I meant by "corresponding" blocks. Technically they are unrelated, the only thing matching them is their z value. I received a dwg output from a Survey Calc program, with strings, points and text containing the z values of the points. No blocks and no attributes. Because this file will be used in other programs than AutoCad, I couldn't simply change the point style via PTYPE, so I inserted a simple cross block I made onto all the points via Lee Mac's Point Manager routine. Worked a treat. What I would love to be able to do is the same as what you have done for me with the text code; - select a group of blocks, anywhere between 2 and 20 - run LISP routine - routine removes all except the one with the highest z value. Hope that clears it up. PS side note, not important for now, but in case I need it in the future. Is it easy to adapt the above code to do the same, but remove the lowest number instead of the highest? Thanks again for all your help. With the text routine, I have plenty to already save me loads of time!

Work like a charm! Thank You! it was so annoying.

Hi, Try this for 3dPolyline (defun l-coor2l-pt (obj lst flag / ) (if lst (cons (list (car lst) (cadr lst) (if flag (+ (if (vlax-property-available-p obj 'Elevation) (vlax-get obj 'Elevation) 0.0) (caddr lst)) (if (vlax-property-available-p obj 'Elevation) (vlax-get obj 'Elevation) 0.0) ) ) (l-coor2l-pt obj (if flag (cdddr lst) (cddr lst)) flag) ) ) ) (defun c:add_vertex-3D ( / ss AcDoc Space interval in n obj_vla l_coor last_p pt pt_vtx new_vtx prm indx flag nw_coor) (princ "\nSelecting an unfited 3Dpolyline") (cond ((setq ss (ssget '((0 . "POLYLINE") (-4 . "<AND") (-4 . "&") (70 . 8) (-4 . "<NOT") (-4 . "&") (70 . 4) (-4 . "NOT>") (-4 . "AND>")))) (initget 15) (setq AcDoc (vla-get-ActiveDocument (vlax-get-acad-object)) Space (if (eq (getvar "CVPORT") 1) (vla-get-PaperSpace AcDoc) (vla-get-ModelSpace AcDoc) ) interval (getdist "\nSpecify interval: ") in interval ) (repeat (setq n (sslength ss)) (setq obj_vla (vlax-ename->vla-object (ssname ss (setq n (1- n)))) l_coor (l-coor2l-pt obj_vla (vlax-get obj_vla 'Coordinates) T) last_p (last l_coor) ) (while (setq pt (vlax-curve-getPointAtDist obj_vla interval)) (setq pt_vtx (vlax-curve-getClosestPointToProjection obj_vla (trans pt 1 0) '(0 0 1) nil) new_vtx (vlax-3d-point last_p) prm (vlax-curve-getParamAtPoint obj_vla pt_vtx) indx -1 ) (vla-AppendVertex obj_vla new_vtx) (repeat (if (vlax-curve-isClosed obj_vla) (fix (vlax-curve-getEndParam obj_vla)) (1+ (fix (vlax-curve-getEndParam obj_vla)))) (setq indx (1+ indx)) (if (or (not (eq indx (1+ (fix prm)))) flag) (setq nw_coor (cons (vlax-curve-getPointAtParam obj_vla indx) nw_coor)) (setq nw_coor (cons pt_vtx nw_coor) indx (1- indx) flag T) ) ) (setq indx -1) (foreach e (reverse nw_coor) (vlax-put-property obj_vla 'Coordinate (setq indx (1+ indx)) (vlax-3d-point e)) ) (setq l_coor (l-coor2l-pt obj_vla (vlax-get obj_vla 'Coordinates) T) last_p (last l_coor) nw_coor nil flag nil interval (+ interval in) ) ) (setq interval in) ) ) (T (princ "\nNothing selected")) ) (prin1) )

@zwonko Try changing the following 2 lines to add "_non" right before the pt variable; this disables the object snaps so the point will be put exactly where the coordinates specify: (command "_.insert" "trójkąt wysokościowy zakresk" "_non" pt scaletrjk "" "0"); <--- add "_non" before pt to disable osnaps (command "_DIMORDINATE" "_non" pt "y" "_non" ptmt); <--- add "_non" before pt and ptmt to disable osnaps P.S. if that is not working. I will need a sample drawing with that block in it to test.

Perhaps explain what you need to do and someone could create or know where this is one already.

Try this (defun c:hcol ( / colobj lay x obj ss ang) (setq colObj (vlax-create-object (strcat "AutoCAD.AcCmColor." (substr (getvar "ACADVER") 1 2)))) (vla-setRGB colObj 120 120 120) (setq ang 100) (setq ang (* pi (/ ang 180.0))) ; convert to radians (setq lay (cdr (assoc 8 (entget (car (entsel "\nPick an object for layer ")))))) (setq ss (ssget "X" (list (cons 0 "HATCH")(cons 8 lay)))) (if (= ss nil) (alert "No hatches detected") (progn (repeat (setq x (sslength ss)) (setq obj (vlax-ename->vla-object (ssname ss (setq x (- x 1))))) (vlax-put obj 'TrueColor colobj) (vlax-put obj 'PatternScale 1.333) (vlax-put obj 'PatternAngle ang) ) ) ) (princ) )