Here is an old routine that may be modified for your use.
;; 03.17.08 CAB modified the block insert to use the Scale of the first
;; block inserted. Also changed the entget to getpoint for the object
;; selection so that osnaps will be visible
;; http://forums.cadalyst.com/showthread.php?p=20949#post20949
;| This routine is further modified by Alan Butler aka CAB aka CAB2k
The routine will work with a block without attributes so I modified
it to work with most blocks in that the break points are determined
by the intersect points of LINES that are farthest apart.
I renamed it BlockInsert for my use. I did minimal testing with a
valve symbol inserted into a pline. No UCS testing.
This routine works by exploding the block, then determining the intersect
points. After the exploded block is removed.
Note that this will not work with all blocks.
|;
;|Routine to label contours drawn by Line/Arc/Polyline. Originally penned by
CiphDRMRS, aka T.Willey, on the AUGI Forums. Modified by Jeff Mishler.
An assumption is made that a valid block with 1 attribute is selected.
|;
(defun c:BlockInsert (/ atts ent entobj inspt
intpts lastent oldecho oldreq oldosnap p1
p2 pt sel tmplist tmplist2 tmpobj
inpt re elst *error*
)
; (setq *bname nil) ; force new block each time, or
;; paste at the command line to reset the block name
(vl-load-com)
(defun *error* (msg)
(if msg
(princ msg)
)
(setvar "attreq" oldreq)
(setvar "osmode" oldosnap)
(command "undo" "end")
(setvar "cmdecho" oldecho)
(princ)
)
;; CAB 05/07/06
;; group on the first three elements A B C of a flat list A B C D E F
;; list must be divisable by 3, no error checking
;; InpLst is the flat list ((A B C) (D E F) (G H I)...)
(defun group_on3 (inplst / outlst tmp grp idx sub)
(while inplst
(setq outlst (cons (list (car inplst) (cadr inplst) (caddr inplst)) outlst))
(setq inplst (cdddr inplst))
)
outlst
)
(setq OldReq (getvar "attreq")
oldecho (getvar "cmdecho")
oldOsnap (getvar "osmode")
)
(setvar "cmdecho" 0)
(command "undo" "end")
(command "undo" "be")
(setvar "attreq" 0)
(setvar "osmode" 512)
;; CAB made *bname var global so that I could reuse the var in a session
;; If you want the block name to be changed at each start uncomment the next line
;; (setq *bname nil)
(while
(and
;; use getpoint for osnaps to work
(setq inspt (getpoint "\n Select object where you wish the block to be inserted: "))
(setq inspt (osnap inspt "_near"))
(setq Sel (nentselp inspt))
)
(setq Ent (car Sel)
entObj (vlax-ename->vla-object Ent)
)
(if (not *bname)
(progn
(setvar "cmdecho" 1)
(initdia)
(command "_.insert")
(command InsPt)
(while (> (getvar "cmdactive") 0)
(command pause)
)
(setvar "cmdecho" 0)
(setq LastEnt (entlast)
elst (entget LastEnt)
*bname (cdr (assoc 2 elst))
*ScaleX (cdr (assoc 41 elst))
*ScaleY (cdr (assoc 42 elst))
)
)
(progn
(setvar "cmdecho" 1)
(command "_.-insert" *bname)
(command InsPt *ScaleX *ScaleY pause)
(setvar "cmdecho" 0)
(setq LastEnt (entlast))
)
)
(setq tmpObj (vlax-ename->vla-object LastEnt)
z (last inspt)
)
(setq tmpList (vlax-invoke tmpObj 'Explode))
;;==================================================================
;; CAB modified this section & removed some code
(setq Intpts nil ; CAB
re nil)
(foreach i tmpList
(mapcar '(lambda (x)
(vlax-invoke x 'move (list 0.0 0.0 0.0) '(0.0 0.0 1e99))
(vlax-invoke x 'move (list 0.0 0.0 0.0) '(0.0 0.0 -1e99))
)
(list entobj i)
)
;; collect all points of intersect
;; CAB revised 11.08.07 to accommodate objects that have more than one
;; intersect point
(if (setq inpt (vlax-invoke entobj 'intersectwith i acextendnone)) ; CAB
(setq inpt (group_on3 inpt) ; CAB revised 11.08.07
intpts (append inpt intpts)) ; CAB revised 11.08.07
)
(vlax-invoke entobj 'move (list 0.0 0.0 0.0) (list 0.0 0.0 z))
(vlax-invoke i 'move (list 0.0 0.0 0.0) (list 0.0 0.0 z))
(vla-delete i)
)
;;==================================================================
;; CAB added this section of code
;; Find the two points farthest apart
(mapcar
'(lambda(x)
(mapcar
'(lambda(y)
(cond
((null re)(setq re (list x y)))
((> (distance x y) (distance (car re) (cadr re)))
(setq re (list x y)))
)
)
IntPts
)
)
IntPts
)
;; restore the Z
(setq p1 (list (caar re) (cadar re) z)
p2 (list (caadr re) (cadadr re) z))
;;==================================================================
(if (and p1 p2)
(command "_.break" Ent
(trans p1 0 1) ; had to add trans to both points
(trans p2 0 1) ; here is the second point
)
(progn
(alert (strcat "Can not break object."
"\n Error in getting the two points needed."
"\nSelect OK then select the 2 points to break at."
)
)
(setvar "osmode" 32)
(if (and (setq p1 (getpoint "\nFirst break point: "))
(setq p2 (getpoint p1 "....second break point: "))
)
(command ".break" Ent p1 p2)
)
(setvar "osmode" 512)
)
)
(if (setq atts (vlax-invoke tmpObj 'getattributes))
(vla-put-textstring (car atts) (rtos z 2 0))
)
)
(*error* nil)
(princ)
)