Recent Posts

Pages: 1 2 [3] 4 5 ... 10
21
I've updated my last post... Now it should find it correctly and for complex xrefs...
So this topic is SOLVED...

Thanks for attention,
M.R.
22
AutoLISP (Vanilla / Visual) / Re: Add zero in number
« Last post by MP on November 08, 2019, 08:58:22 PM »
Another for fun:

(defun p (x) (strcat (if (< (strlen (setq x (vl-princ-to-string x))) 2) "0" "") x))

(p 1)      >> "01"
(p "2")    >> "02"
(p 10)     >> "10"
(p "1000") >> "1000"
23
AutoLISP (Vanilla / Visual) / Re: entmod not working
« Last post by BIGAL on November 08, 2019, 08:27:54 PM »
This is were vl is so much easier (vla-put-layer obj newlayer) and to understand.
24
AutoLISP (Vanilla / Visual) / Re: Add zero in number
« Last post by BIGAL on November 08, 2019, 08:25:34 PM »
Another example we use D01, D10 etc

Code: [Select]
; if less than 10
    (if (< (car dwgnum) 10.0)
      (setq newstr2 (strcat dwgname "-D0"  (rtos sheetnum 2 0)))
      (setq newstr2 (strcat dwgname "-D"  (rtos sheetnum 2 0)))
    )
25
This is terribly slow and it will solve it correctly...

Code - Auto/Visual Lisp: [Select]
  1. (defun findclosestpointtonestedinblkref ( blkref wcspt / refgeom trp mxm mxv LM:InverseMatrix processclosestpointto processclosestpointtoinv collectblkrefs collectallentsfromref collectallcurvesnestedinblkrefwithparentrefassociations stblkref blkrefinl stblkrefrefel pl curreflst rg )
  2.  
  3.  
  4.   ;; RefGeom (gile)
  5.   ;; Returns a list whose first item is a 3x3 transformation matrix and
  6.   ;; second item the object insertion point in its parent (xref, block or space)
  7.  
  8.   (defun refgeom ( ent / ang enx mat ocs )
  9.       (setq enx (entget ent)
  10.             ang (cdr (assoc 050 enx))
  11.             ocs (cdr (assoc 210 enx))
  12.       )
  13.       (list
  14.           (setq mat
  15.               (mxm
  16.                   (mapcar '(lambda ( v ) (trans v 0 ocs t))
  17.                      '(
  18.                           (1.0 0.0 0.0)
  19.                           (0.0 1.0 0.0)
  20.                           (0.0 0.0 1.0)
  21.                       )
  22.                   )
  23.                   (mxm
  24.                       (list
  25.                           (list (cos ang) (- (sin ang)) 0.0)
  26.                           (list (sin ang) (cos ang)     0.0)
  27.                          '(0.0 0.0 1.0)
  28.                       )
  29.                       (list
  30.                           (list (cdr (assoc 41 enx)) 0.0 0.0)
  31.                           (list 0.0 (cdr (assoc 42 enx)) 0.0)
  32.                           (list 0.0 0.0 (cdr (assoc 43 enx)))
  33.                       )
  34.                   )
  35.               )
  36.           )
  37.           (mapcar '- (trans (cdr (assoc 10 enx)) ocs 0)
  38.               (mxv mat (cdr (assoc 10 (tblsearch "BLOCK" (cdr (assoc 2 enx))))))
  39.           )
  40.       )
  41.   )
  42.  
  43.   ;; Matrix Transpose  -  Doug Wilson
  44.   ;; Args: m - nxn matrix
  45.  
  46.   (defun trp ( m )
  47.       (apply 'mapcar (cons 'list m))
  48.   )
  49.  
  50.   ;; Matrix x Matrix  -  Vladimir Nesterovsky
  51.   ;; Args: m,n - nxn matrices
  52.  
  53.   (defun mxm ( m n )
  54.       ((lambda ( a ) (mapcar '(lambda ( r ) (mxv a r)) m)) (trp n))
  55.   )
  56.  
  57.   ;; Matrix x Vector  -  Vladimir Nesterovsky
  58.   ;; Args: m - nxn matrix, v - vector in R^n
  59.  
  60.   (defun mxv ( m v )
  61.       (mapcar '(lambda ( r ) (apply '+ (mapcar '* r v))) m)
  62.   )
  63.  
  64.   ;;--------------------=={ Inverse Matrix }==------------------;;
  65.   ;;                                                            ;;
  66.   ;;  Implements the Gauss-Jordan Elimination algorithm to      ;;
  67.   ;;  inverse a non-singular nxn matrix.                        ;;
  68.   ;;------------------------------------------------------------;;
  69.   ;;  Author: Lee Mac, Copyright 2011 - www.lee-mac.com       ;;
  70.   ;;------------------------------------------------------------;;
  71.   ;;  Arguments: m - nxn Matrix                                 ;;
  72.   ;;------------------------------------------------------------;;
  73.   ;;  Returns:  Matrix inverse, or nil if matrix is singular    ;;
  74.   ;;------------------------------------------------------------;;
  75.  
  76.   (defun LM:InverseMatrix ( m / _identity _eliminate p r x )
  77.  
  78.     (defun _identity ( n / i j l m ) (setq i 1)
  79.       (repeat n (setq j 0)
  80.         (repeat n
  81.           (setq l (cons (if (= i (setq j (1+ j))) 1. 0.) l))
  82.         )
  83.         (setq m (cons l m) l nil i (1+ i)) m
  84.       )
  85.     )
  86.  
  87.     (defun _eliminate ( m p )
  88.       (mapcar
  89.         (function
  90.           (lambda ( x / d )
  91.             (setq d (car x)) (mapcar (function (lambda ( a b ) (- a (* d b)))) (cdr x) p)
  92.           )
  93.         )
  94.         m
  95.       )
  96.     )
  97.     (setq m (mapcar 'append m (_identity (length m))))
  98.    
  99.     (while m
  100.       (setq p (apply 'max (mapcar 'abs (mapcar 'car m))))
  101.       (while (not (equal p (abs (caar m)) 1e-14))
  102.         (setq m (append (cdr m) (list (car m))))
  103.       )
  104.       (if (equal 0.0 (caar m) 1e-14)
  105.         (setq m nil)
  106.         (setq p (/ 1. (caar m))
  107.               p (mapcar (function (lambda ( x ) (* p x))) (cdar m))
  108.               m (_eliminate (cdr m) p)
  109.               r (cons p (_eliminate r p))
  110.         )
  111.       )
  112.     )
  113.     (reverse r)
  114.   )
  115.  
  116.   (defun processclosestpointto ( parentlst pt / parent )
  117.     (setq parentlst (cdr parentlst))
  118.     (if parentlst
  119.       (while (setq parent (car parentlst))
  120.         (setq pt ((lambda ( matveclst ) (mapcar '+ (mxv (car matveclst) pt) (cadr matveclst))) (refgeom parent)))
  121.         (setq parentlst (cdr parentlst))
  122.       )
  123.     )
  124.     pt
  125.   )
  126.  
  127.   (defun processclosestpointtoinv ( parentlst pt / child )
  128.     (setq parentlst (cdr (reverse parentlst)))
  129.     (if parentlst
  130.       (while (setq child (car parentlst))
  131.         (setq pt ((lambda ( matveclst ) (mxv (LM:InverseMatrix (car matveclst)) (mapcar '- pt (cadr matveclst)))) (refgeom child)))
  132.         (setq parentlst (cdr parentlst))
  133.       )
  134.     )
  135.     pt
  136.   )
  137.  
  138.   (defun collectblkrefs ( blkref / el ee )
  139.     (setq blkrefinl (cons blkref blkrefinl))
  140.     (setq el (collectallentsfromref blkref))
  141.     (setq el (vl-sort el '(lambda ( a b ) (< (cdr (assoc 5 (entget a))) (cdr (assoc 5 (entget b)))))))
  142.     (foreach ee el
  143.       (if (= (cdr (assoc 0 (entget ee))) "INSERT")
  144.         (collectblkrefs ee)
  145.       )
  146.     )
  147.   )
  148.  
  149.   (defun collectallentsfromref ( blkref / e el )
  150.  
  151.     (vl-load-com)
  152.  
  153.     (setq e (tblobjname "BLOCK" (vla-get-effectivename (vlax-ename->vla-object blkref))))
  154.     (while (setq e (entnext e))
  155.       (setq el (cons e el))
  156.     )
  157.     el
  158.   )
  159.  
  160.   (defun collectallcurvesnestedinblkrefwithparentrefassociations ( blkref / unique e el ex gg ggl gggl ggx ggxl q qq ql f ff fff ffff )
  161.  
  162.     (vl-load-com)
  163.  
  164.     (defun unique ( l )
  165.       (if l (cons (car l) (unique (vl-remove-if '(lambda ( x ) (equal x (car l))) l))))
  166.     )
  167.  
  168.     (if (null stblkref)
  169.       (setq stblkref blkref)
  170.     )
  171.     (if (null blkrefinl)
  172.       (collectblkrefs stblkref)
  173.     )
  174.     (if (null stblkrefrefel)
  175.       (setq stblkrefrefel (vl-remove-if-not '(lambda ( x ) (= (cdr (assoc 0 (entget x))) "INSERT")) (collectallentsfromref stblkref)))
  176.     )
  177.     (setq el (collectallentsfromref blkref))
  178.     (setq el (vl-sort el '(lambda ( a b ) (< (cdr (assoc 5 (entget a))) (cdr (assoc 5 (entget b)))))))
  179.     (foreach e el
  180.       (setq ex (entget e))
  181.       (cond
  182.         ( (wcmatch (cdr (assoc 0 ex)) "*POLYLINE,SPLINE,XLINE,LINE,RAY,ARC,CIRCLE,ELLIPSE,HELIX")
  183.           (setq gg (cons (setq qq blkref) gg))
  184.           (if (not (eq qq stblkref))
  185.             (progn
  186.               (setq ggl (cons gg ggl))
  187.               (while (and ggl (not (vl-every '(lambda ( x ) (vl-position (car x) stblkrefrefel)) ggl)) (not (equal ggl gggl)))
  188.                 (setq gggl ggl)
  189.                 (if (null fff)
  190.                   (setq ggl nil)
  191.                 )
  192.                 (setq fff t)
  193.                 (foreach q (if ffff (mapcar 'car ggl) (list qq))
  194.                   (while (and (null ff) (setq ql (unique (vl-remove-if-not '(lambda ( x ) (vl-position q (collectallentsfromref x))) (vl-remove q blkrefinl)))) (if ggl (not (vl-every '(lambda ( x ) (vl-position (car x) stblkrefrefel)) ggl)) t))
  195.                     (if (null f)
  196.                       (foreach g ql
  197.                         (setq ggl (cons (cons g gg) ggl))
  198.                       )
  199.                       (progn
  200.                         (setq ggx (vl-remove-if-not '(lambda ( x ) (eq q (car x))) ggl))
  201.                         (setq ggl (vl-remove-if '(lambda ( x ) (vl-position x ggx)) ggl))
  202.                         (foreach xx ggx
  203.                           (setq ggx (mapcar '(lambda ( x ) (cons x xx)) ql))
  204.                           (setq ggxl (cons ggx ggxl))
  205.                         )
  206.                         (if ggxl
  207.                           (setq ggl (append (apply 'append ggxl) ggl))
  208.                         )
  209.                         (setq ggxl nil)
  210.                       )
  211.                     )
  212.                     (setq f t)
  213.                     (if (or (eq q qq) (eq q (cadar ggl)))
  214.                       (setq ff t)
  215.                       (setq ff nil)
  216.                     )
  217.                   )
  218.                   (setq ff nil ffff t)
  219.                   (setq ggl (unique ggl))
  220.                 )
  221.               )
  222.               (if (null ggl)
  223.                 (setq ggl (cons gg ggl))
  224.               )
  225.               (setq ggl (mapcar '(lambda ( x ) (cons stblkref x)) ggl))
  226.             )
  227.             (setq ggl (cons gg ggl))
  228.           )
  229.           (foreach gg ggl
  230.             (setq curreflst (cons (list e (reverse gg)) curreflst))
  231.           )
  232.           (setq gg nil ggl nil gggl nil ggx nil ggxl nil q nil qq nil ql nil f nil ff nil fff nil ffff nil)
  233.         )
  234.         ( (= (cdr (assoc 0 ex)) "INSERT")
  235.           (collectallcurvesnestedinblkrefwithparentrefassociations e)
  236.         )
  237.       )
  238.     )
  239.     curreflst
  240.   )
  241.  
  242.   (foreach curref (setq curreflst (collectallcurvesnestedinblkrefwithparentrefassociations blkref))
  243.     (setq pl (cons (processclosestpointto (cadr curref) ((lambda ( matveclst ) (mapcar '+ (mxv (car matveclst) (vlax-curve-getclosestpointto (car curref) (processclosestpointtoinv (cadr curref) (mxv (LM:InverseMatrix (car (setq rg (refgeom (last (cadr curref)))))) (mapcar '- wcspt (cadr rg)))))) (cadr matveclst))) (refgeom (car (cadr curref))))) pl))
  244.   )
  245.   (car (vl-sort pl '(lambda ( a b ) (< (distance a wcspt) (distance b wcspt)))))
  246. )
  247.  
  248. (defun c:findclosestpointtonestedinblkref ( / blkref wcspt p )
  249.   (while
  250.     (or
  251.       (not (setq blkref (car (entsel "\nPick INSERT entity..."))))
  252.       (if blkref
  253.         (/= (cdr (assoc 0 (entget blkref))) "INSERT")
  254.       )
  255.     )
  256.     (prompt "\nMissed or picked wrong entity type...")
  257.     (textscr)
  258.   )
  259.   (initget 1)
  260.   (setq wcspt (trans (getpoint "\nPick or specify point : ") 1 0))
  261.   (princ (setq p (findclosestpointtonestedinblkref blkref wcspt)))
  262.   (entmake (list '(0 . "POINT") (cons 10 p)))
  263.   (princ)
  264. )
  265.  

M.R.
26
AutoLISP (Vanilla / Visual) / Re: Add zero in number
« Last post by Lee Mac on November 08, 2019, 05:34:20 PM »
Another -
Code - Auto/Visual Lisp: [Select]
  1. (defun f ( s ) (substr (strcat "0" s) (min 2 (strlen s))))
Code - Auto/Visual Lisp: [Select]
  1. _$ (f "1")
  2. "01"
  3. _$ (f "10")
  4. "10"
  5. _$ (f "100")
  6. "100"
  7. _$ (f "1000")
  8. "1000"
27
AutoLISP (Vanilla / Visual) / Re: Add zero in number
« Last post by PKENEWELL on November 08, 2019, 05:10:39 PM »
Try This:

Code: [Select]
;|==============================================================================
  Function Name: (pjk-leadzeros)
  Arguments:
     dig = integer; number of total digits represented in the string. must be
           greater than zero.
     str = string; a string representing a positive integer. must not have any
           alpha characters or decimal points, minus sign, etc...
  Usage: (pjk-leadzeros <Number of Digits> <String>)
  Returns:
     > The resulting string with leading zeros if the digits are greater than the
       integer represented, the original string if the interger has equal or more
       digits than <dig>. NIL if any argument is invalid
  Description:
     This function converts a string representing an integer number to a string
     with the integer including leading zeros. This is extremely useful when used
     within a sorted index to prevent single digit sorting common to windows (e.g.
     1, 10, 11, 12..., 2, 20, 21, 22...)
================================================================================|;
(defun pjk-leadzeros (dig str)
   (if (and dig str
          (= (type dig) 'INT)
          (= (type str) 'STR)
          (> dig 0)
      )
(repeat (- dig (strlen str))(setq str (strcat "0" str)))
(setq str nil)
   )
   str
) ;; End Function (pjk-leadzeros)
28
CAD General / Re: STB with multiple style, how to use substyle?
« Last post by pkohut on November 08, 2019, 05:01:18 PM »
Sure.  Till this past week I had not seen a STB with many sub styles defined, or if I had never paid attention to them.
29
CAD General / Re: STB with multiple style, how to use substyle?
« Last post by 57gmc on November 08, 2019, 04:51:22 PM »
Default.

Some in the group use Civil 3d others use Carlson Survey.  Each group feels the other group are knuckle heads. 
And yet somehow you are able to have a layer standard that utilizes named plot styles that requires you don't change it at the layer level? That means that you standardize on a single plot style, Normal.
30
CAD General / Re: STB with multiple style, how to use substyle?
« Last post by pkohut on November 08, 2019, 04:45:08 PM »
Default.

Some in the group use Civil 3d others use Carlson Survey.  Each group feels the other group are knuckle heads. 
Pages: 1 2 [3] 4 5 ... 10