alanjt's Misc. Useful Lisp Subroutines

[alanjt]

;;; Return all all duplicates within list
;;; #List - List to process
;;; Alan J. Thompson, 11.01.09
(defun AT:ListDuplicates (#List)
 (vl-remove-if-not
   '(lambda (x) (member x (cdr (member x #List))))
   #List
 ) ;_ vl-remove-if-not
) ;_ defun

[alanjt]

;;; Insert block into drawing
;;; #Name - name of block
;;; #InsPt - insert point
;;; #XScale - block X scale
;;; #YScale - block Y scale
;;; #Rot - block rotation
;;; Alan J. Thompson, 04.21.09
(defun AT:InsertBlock (#Name #InsPt #XScale #YScale #Rot)
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (if (or (tblsearch "block" #Name)
         (findfile #Name)
     ) ;_ or
   (vla-insertblock
     (if (or (eq acmodelspace (vla-get-activespace *AcadDoc*))
             (eq :vlax-true (vla-get-mspace *AcadDoc*))
         ) ;_ or
       (vla-get-modelspace *AcadDoc*)
       (vla-get-paperspace *AcadDoc*)
     ) ;_ if
     (if (vl-consp #InsPt)
       (vlax-3d-point #InsPt)
       #InsPt
     ) ;_ if
     #Name
     #XScale
     #YScale
     #XScale
     #Rot
   ) ;_ vla-insert-block
 ) ;_ if
) ;_ defun

[alanjt]

;;; Offset selected object
;;; #Ent&Point - List of entity and point
;;; #Dist - Distance to offset object
;;; #Point - Point on side of object to offset
;;; Alan J. Thompson, 09.12.09
(defun AT:Offset (#Ent&Point #Dist #Point / #POC1 #POC2 #Obj #Dist #Check)
 ;; get first point on curve
 (setq #POC1 (vlax-curve-getClosestPointTo
               (setq #Obj (vlax-ename->vla-object (car #Ent&Point)))
               (trans (cadr #Ent&Point) 1 0)
             ) ;_ vlax-curve-getClosestPointTo
 ) ;_ setq
 ;; get another point on curve, 0.0001 away
 (setq #POC2 (vlax-curve-getPointAtDist
               #Obj
               (+ (vlax-curve-getDistAtPoint #Obj #POC1) 0.0001)
             ) ;_ vlax-curve-getPointAtDist
 ) ;_ setq
 ;; determine which side #Point is on and set distance for offset
 (if (minusp (- (* (- (car #POC2) (car #POC1))
                   (- (cadr (trans #Point 1 0)) (cadr #POC1))
                ) ;_ *
                (* (- (cadr #POC2) (cadr #POC1))
                   (- (car (trans #Point 1 0)) (car #POC1))
                ) ;_ *
             ) ;_ -
     ) ;_ minusp
   (if (member (vla-get-objectname #Obj) '("AcDbLine" "AcDbXline"))
     (setq #Dist (- (abs #Dist)))
     (setq #Dist (abs #Dist))
   ) ;_ if
   (if (member (vla-get-objectname #Obj) '("AcDbLine" "AcDbXline"))
     (setq #Dist (abs #Dist))
     (setq #Dist (- (abs #Dist)))
   ) ;_ if
 ) ;_ if
 ;; offset object
 (if (not (vl-catch-all-error-p
            (setq #Check (vl-catch-all-apply
                           'vla-offset
                           (list #Obj #Dist)
                         ) ;_ vl-catch-all-apply
            ) ;_ vl-catch-all-error-p
          ) ;_ vl-catch-all-error-p
     ) ;_ not
   (car (vlax-safearray->list (vlax-variant-value #Check)))
 ) ;_ if
) ;_ defun

[Least]

;;; Extract all Attributes from Block or Multileader w/Block
;;; #Object - Block/Multileader to extract attributes
;;; Alan J. Thompson, 08.17.09
(defun AT:GetAttributes (#Object / #Object #Entget)
 (if #Object
   (progn
     ;; if list, strip out ename
     (and (vl-consp #Object) (setq #Object (car #Object)))
     (cond
       ;; if vla-object & multileader with block, convert to ename
       ((and (eq (type #Object) 'VLA-OBJECT)
             (vlax-property-available-p #Object 'ContentBlockName)
        ) ;_ and
        (setq #Object (vlax-vla-object->ename #Object))
       )
       ;; if ename & block, convert to vla-object
       ((and (eq (type #Object) 'ENAME)
             (eq "INSERT" (cdr (assoc 0 (entget #Object))))
        ) ;_ and
        (setq #Object (vlax-ename->vla-object #Object))
       )
     ) ;_ cond
     ;; run through options
     (cond
       ;; vla-object & attributed block
       ((and (eq (type #Object) 'VLA-OBJECT)
             (eq "AcDbBlockReference"
                 (vla-get-objectname #Object)
             ) ;_ eq
             (eq (vla-get-hasattributes #Object) :vlax-true)
        ) ;_ and
        (vlax-safearray->list
          (vlax-variant-value
            (vla-getattributes #Object)
          ) ;_ vlax-variant-value
        ) ;_ vlax-safearray->list
       )
       ;; ename or entsel-style list
       ((or (eq (type #Object) 'ENAME)
            (vl-consp #Object)
        ) ;_ or
        (setq #Entget (entget #Object))
        (vl-remove-if
          '(lambda (x)
             (or (not x)
                 (not (eq "AcDbAttributeDefinition"
                          (vla-get-objectname x)
                      ) ;_ eq
                 ) ;_ not
             ) ;_ or
           ) ;_ lambda
          (mapcar
            '(lambda (x)
               (if (eq 330 (car x))
                 (vlax-ename->vla-object (cdr x))
               ) ;_ if
             ) ;_ lambda
            #Entget
          ) ;_ mapcar
        ) ;_ vl-remove-if
       )
     ) ;_ cond
   ) ;_ progn
 ) ;_ if
) ;_ defun

 

Hi Alan

Thanks for making these lisps available. I tried to run this lisp, but wasn't quite sure what to do.

The block I wish to export attributes from is called PT2. Does this lisp also export the X and Y coordinates of the block's insertion point?

 

Cheers

Pads

[Lee Mac]

Bear in mind that this is a Sub-Routine, and need to be fed arguments to process.

[Least]

Ok thanks, I think I'll leave it.

I need a lot more comments to be able to understand and then possibly make use of it.

cheers

P

[alanjt]

Hi Alan

Thanks for making these lisps available. I tried to run this lisp, but wasn't quite sure what to do.

The block I wish to export attributes from is called PT2. Does this lisp also export the X and Y coordinates of the block's insertion point?

 

Cheers

Pads

You are welcome.

This is my subroutine section and as Lee said, you have to feed it certain arguments. Exaple: (AT:GetAttributes (entsel)).

 

In regards to extracting the X/Y, as prefaced in the code, it is for extracting attribute objects from attributed blocks and attributed block mleaders. Subroutines are written with specific purposes.

[asos2000]

Thanks alanjt

 

whats deffirence between

(setq #Dist (abs #Dist))

and

(setq Dist (abs Dist))

 

or in other hand

what is usage of adding # and * ?

[Lee Mac]

or in other hand

what is usage of adding # and * ?

 

Nothing, just his dodgy coding style

[asos2000]

LOL

 

MY dodgy coding is #*

[alanjt]

It's just my way of keeping organized; OCD.

1. #Variable = local variable
   
2. RN:#Variable = global variable pertaining to a specific routine (RN = RoutineName)
   
3. *Variable* = global variable that can be used my multiple routines
   
4. AT:Name = global or localized subroutine that I will use multiple times
   
5. _Name = local subroutine (or sub-subroutine) specifically pertaining to a routine or subroutine.

[asos2000]

Thanks alanjt for your clarification

[alanjt]

Thanks alanjt for your clarification

 

No problem.

As you can see, I'm a little **** retentive.

[asos2000]

Same is here

[alanjt]

;;; List of layouts (VLA-Objects) in drawing (in correct order)
;;; Alan J. Thompson, 10.05.09
(defun AT:LayoutList (/ #Layouts)
 (or *AcadDoc* (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object))))
 (vlax-for x (vla-get-layouts *AcadDoc*)
   (or (eq (vla-get-name x) "Model") (setq #Layouts (cons x #Layouts)))
 ) ;_ vlax-for
 (vl-sort #Layouts '(lambda (x y) (< (vla-get-taborder x) (vla-get-taborder y))))
) ;_ defun

 

Just in case : (mapcar 'vla-get-name (AT:LayoutList))

[alanjt]

;;; SSGet Replacement, with prompt
;;; #Msg - Display message
;;; #Type - Selection method (ie: "_X", "_:L"), nil if not
;;; #Filter - Selection filter, nil if not
;;; Alan J. Thompson, 10.31.09
(defun AT:SSGet (#Msg #Meth #Filter / *error* #SS)
 (setq *error* (lambda (x) (setvar "nomutt" 0)))
 (and #Msg (prompt #Msg))
 (setvar "nomutt" 1)
 (if #Meth
   (setq #SS (ssget #Meth #Filter))
   (setq #SS (ssget #Filter))
 ) ;_ if
 (*error* nil)
 #SS
) ;_ defun

 

;;; Subtract matching enames from selection set
;;; ss1 - Selection set to evaluate
;;; ss2 - Selection set to compare with
;;; Alan J. Thompson, 11.25.09
(defun AT:SSRemove (ss1 ss2 / ss3 n)
 (setq n   -1
       ss3 ss1
 ) ;_ setq
 (repeat (sslength ss2)
   (if (ssmemb (setq o (ssname ss2 (setq n (1+ n))))
               ss3
       ) ;_ ssmemb
     (ssdel o ss3)
   ) ;_ if
 ) ;_ repeat
 ss3
) ;_ defun

[alanjt]

;;; Retreive segment number and Start & End points
;;; #Obj&PntList - List with object & point
;;; Alan J. Thompson, 11.10.09
(defun AT:Segment (#Obj&PntList / #Seg #Temp #Pnts)
 (cond
   ((vl-consp #Obj&PntList)
    (setq #Seg  (fix (vlax-curve-getparamatpoint
                       (car #Obj&PntList)
                       (vlax-curve-getclosestpointto (car #Obj&PntList) (trans (cadr #Obj&PntList) 1 0))
                     ) ;_ vlax-curve-getparamatpoint
                ) ;_ fix
          #Pnts (list (vlax-curve-getpointatparam (car #Obj&PntList) #Seg)
                      (if (setq #Temp (vlax-curve-getpointatparam (car #Obj&PntList) (1+ #Seg)))
                        #Temp
                        (vlax-curve-getpointatparam (car #Obj&PntList) (1- #Seg))
                      ) ;_ if
                ) ;_ list
    ) ;_ setq
    (vl-remove null (list #Seg #Pnts))
   )
 ) ;_ cond
) ;_ defun

[alanjt]

;;; Retrieve closest end point on object
;;; #Ent&PntList - List with object and point
;;; Alan J. Thompson, 11.10.09
(defun AT:ClosestEndPoint (#Ent&PntList / #Pnt)
 (and (vl-consp #Ent&PntList)
      (setq #Pnt (vlax-curve-getclosestpointto (car #Ent&PntList) (trans (cadr #Ent&PntList) 1 0)))
      (setq #Pnt (car (vl-sort (list (vlax-curve-getstartpoint (car #Ent&PntList))
                                     (vlax-curve-getendpoint (car #Ent&PntList))
                               ) ;_ list
                               '(lambda (a b) (< (distance #Pnt a) (distance #Pnt b)))
                      ) ;_ vl-sort
                 ) ;_ car
      ) ;_ setq
 ) ;_ and
 #Pnt
) ;_ defun

[alanjt]

;;; Rename block definition
;;; #OldName - Name of block to rename
;;; #NewName - New name for block
;;; Alan J. Thompson, 10.07.09
(defun AT:BlockRename (#OldName #NewName)
 (and
   (tblsearch "block" #OldName)
   (not (tblsearch "block" #NewName))
   (snvalid #NewName)
   (or *AcadDoc*
       (setq *AcadDoc* (vla-get-activedocument (vlax-get-acad-object)))
   ) ;_ or
   (not (vl-catch-all-error-p
          (vl-catch-all-apply
            'vla-put-name
            (list (vla-item (vla-get-blocks *AcadDoc*) #OldName) #NewName)
          ) ;_ vl-catch-all-apply
        ) ;_ vl-catch-all-error-p
   ) ;_ not
 ) ;_ and
) ;_ defun

[alanjt]

;;; Get name of block (works with Dynamic blocks)
;;; #Obj - Block (vla-object) of interest
;;; Alan J. Thompson, 10.13.09
(defun AT:BlockName (#Obj)
 (if (vlax-property-available-p #Obj 'EffectiveName)
   (vla-get-effectivename #Obj)
   (vla-get-name #Obj)
 ) ;_ if
) ;_ defun