Hi Matthew,
I've updated my code to WBLOCK the block to a drawing file in the same folder as the currently open drawing.
If the block drawing file exists in the folder, it will be deleted and replaced.
Also, if the block already exists in the drawing, it won't be redefined if new objects are selected.
If the block needs to be redefined, then all inserts will need to be deleted, then PURGE the block from the drawing.
If required, I can modify my code to always redefine the block if it exists.
;; WBFileBlock.lsp by Trevor Bird
;;
;; 2022-05-17
;;------------------------------------------------------------------------------
(defun c:wbfileblock
(
/
acadver_int
acadver_str
ascii_list
attribs_list
attribs_var
bl_wcs_list
col_Blocks
col_Block_area
Coordinates_ocs_list
Coordinates_ocs_var
Coordinates_ucs_list
Coordinates_wcs_list
Coordinate_ocs_list
Coordinate_ocs_var
Coordinate_wcs_list
detail_block_str
dp_410
ename_polyline
file_block_str
file_fqn
file_name_str
insert1_ename
insert2_ename
insert_name
list_block_objects
mt_4x4_wcs1_list
mt_4x4_wcs2_list
ObjectName
objects1_sa
objects2_list
objects2_var
obj_ACAD
obj_AD
obj_insert
ss_insert1
ss_insert2
ss_objects
ss_objects__enames
ss_objects__objects
ss_polylines
ss_polylines__enames
ss_polylines__objects
sv_acadver
sv_dwgprefix
tagstring_str
textstring_str
vertex_count
vertex_index
vertex_Z
)
(if (= (getvar 'CVPORT) 1)
(setq dp_410 (cons 410 (getvar 'CTAB)))
(setq dp_410 '(410 . "Model"))
);if (= (getvar 'CVPORT) 1)
(setq ss_polylines
(ssget
(list
'(0 . "*POLYLINE")
'(-4 . "<AND")
'(-4 . "&")
'(70 . 1) ; 1 = This is a closed polyline
'(-4 . "<NOT") ; Exclude 3D polylines
'(-4 . "&=") ; 8 = This is a 3D polyline
'(70 . 8)
'(-4 . "NOT>")
'(-4 . "AND>")
dp_410
);list
);ssget
);setq
(cond
( (not ss_polylines)
(princ "\nNo closed polylines selected.")
);(not ss_polylines)
(ss_polylines
(setq obj_ACAD (vlax-get-acad-object)
obj_AD (vlax-get-property obj_ACAD 'ActiveDocument)
col_Blocks (vlax-get-property obj_AD 'Blocks)
sv_acadver (getvar 'ACADVER)
acadver_int (atoi sv_acadver)
acadver_str (itoa acadver_int)
sv_dwgprefix (getvar 'DWGPREFIX)
);setq
(setq ss_polylines__enames (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_polylines)))
ss_polylines__objects (mapcar 'vlax-ename->vla-object ss_polylines__enames)
);setq
(foreach fe__obj_polyline ss_polylines__objects
(setq ename_polyline (vlax-vla-object->ename fe__obj_polyline)
ObjectName (vlax-get-property fe__obj_polyline 'ObjectName)
Coordinates_ocs_var (vlax-get-property fe__obj_polyline 'Coordinates)
Coordinates_ocs_list (vlax-safearray->list (vlax-variant-value Coordinates_ocs_var))
Coordinates_wcs_list nil
);setq
(cond
( (= ObjectName "AcDbPolyline")
;; Lightweight Polyline
(setq vertex_count (/ (length Coordinates_ocs_list) 2)
vertex_Z (vlax-get-property fe__obj_polyline 'Elevation)
);setq
);(= ObjectName "AcDbPolyline")
( (or
(= ObjectName "AcDb2dPolyline")
(= ObjectName "AcDb3dPolyline")
);or
;; Heavy Polyline
(setq vertex_count (/ (length Coordinates_ocs_list) 3)
vertex_Z nil
);setq
);
);cond
(setq vertex_index 0)
(while (< vertex_index vertex_count)
(setq Coordinate_ocs_var (vlax-get-property fe__obj_polyline 'Coordinate vertex_index)
Coordinate_ocs_list (vlax-safearray->list (vlax-variant-value Coordinate_ocs_var))
vertex_index (1+ vertex_index)
);setq
(if vertex_Z
(setq Coordinate_ocs_list (append Coordinate_ocs_list (list vertex_Z)))
);if vertex_Z
(setq Coordinate_wcs_list (trans Coordinate_ocs_list ename_polyline 0)
Coordinates_wcs_list (append Coordinates_wcs_list (list Coordinate_wcs_list))
);setq
);while (< vertex_index vertex_count)
(setq Coordinates_ucs_list (mapcar (function (lambda ( _point_wcs ) (trans _point_wcs 0 1))) Coordinates_wcs_list))
(cond
( (not
(setq ss_insert1
(ssget "_WP"
Coordinates_ucs_list
(list
'(0 . "INSERT")
'(2 . "FILE BLOCK")
'(66 . 1)
dp_410
);list
);ssget
);setq
);not
(princ "\n") (prin1 "FILE BLOCK") (princ " not found.")
);
( (not
(setq ss_insert2
(ssget "_WP"
Coordinates_ucs_list
(list
'(0 . "INSERT")
'(2 . "DETAIL TITLE BLOCK")
'(66 . 1)
dp_410
);list
);ssget
);setq
);not
(princ "\n") (prin1 "DETAIL TITLE BLOCK") (princ " not found.")
);
( (not
(setq ss_objects
(ssget "_WP"
Coordinates_ucs_list
(list
'(-4 . "<NOT")
'(-4 . "<AND")
'(0 . "INSERT")
'(2 . "FILE BLOCK,DETAIL TITLE BLOCK")
'(-4 . "AND>")
'(-4 . "NOT>")
dp_410
);list
);ssget
);setq
);not
(princ "\nNo objects found for file block creation.")
);
( (not
(progn
(setq insert1_ename (ssname ss_insert1 0)
insert2_ename (ssname ss_insert2 0)
ss_objects__enames (vl-remove-if 'listp (mapcar 'cadr (ssnamex ss_objects)))
ss_objects__objects (mapcar 'vlax-ename->vla-object ss_objects__enames)
file_block_str nil
detail_block_str nil
);setq
;; Process attributes of blocks to determine file name components
(foreach fe__ename
(list
insert1_ename
insert2_ename
);list
(setq obj_insert (vlax-ename->vla-object fe__ename)
insert_name (vlax-get-property obj_insert 'Name)
attribs_var (vlax-invoke-method obj_insert 'GetAttributes)
attribs_list (vlax-safearray->list (vlax-variant-value attribs_var))
);setq
(foreach fe__obj_attrib attribs_list
(setq tagstring_str (vlax-get-property fe__obj_attrib 'TagString))
(cond
( (and
(/= tagstring_str "DPS-#")
(/= tagstring_str "TITLE")
);and
);
( (not
(setq textstring_str (vlax-get-property fe__obj_attrib 'TextString)
ascii_list (vl-remove-if (function (lambda ( _chr_code ) (= (ascii " ") _chr_code))) (vl-string->list textstring_str))
);setq
);not
;; Attribute value is empty.
(princ "\nRequired attribute value is empty in block ") (prin1 insert_name) (princ ".")
);
( (not
(setq textstring_str (vl-string-right-trim " " textstring_str)
textstring_str (vl-string-left-trim " " textstring_str)
ascii_list (vl-remove-if (function (lambda ( _chr_code ) (= (ascii " ") _chr_code))) (vl-string->list textstring_str))
);setq
);not
);
( (not file_block_str)
(setq file_block_str textstring_str)
);(not file_block_str)
( (not detail_block_str)
(setq detail_block_str textstring_str)
);(not detail_block_str)
);cond
(vlax-release-object fe__obj_attrib)
);fe__obj_attrib
(vlax-release-object obj_insert)
);fe__ename
(and
file_block_str
detail_block_str
);and
);progn
);not
(princ "\nFile block name cannot be determined from the attributed block values.")
);
( (and
file_block_str
tagstring_str
);and
(setq file_name_str (strcat file_block_str " " detail_block_str)
file_fqn (strcat sv_dwgprefix file_name_str ".dwg")
);setq
(if (findfile file_fqn)
(vl-file-delete file_fqn)
);if (findfile file_fqn)
(setq list_block_objects (list fe__obj_polyline)
list_block_objects (append list_block_objects ss_objects__objects)
objects1_sa (vlax-make-safearray vlax-vbObject (cons 0 (1- (length list_block_objects))))
);setq
(vlax-safearray-fill objects1_sa list_block_objects)
;; Determine bottom left corner of selected area.
;; This point will be the insertion point of the block.
(setq bl_wcs_list
(list
(apply 'min (mapcar 'car Coordinates_wcs_list))
(apply 'min (mapcar 'cadr Coordinates_wcs_list))
(apply 'min (mapcar 'caddr Coordinates_wcs_list))
);list
);setq
;; Insertion base point of block definition is 0,0,0.
;; The bottom left corner of each selected polyline is not 0,0,0.
;; Transform objects in block definition to be relative to 0,0,0.
(setq mt_4x4_wcs1_list
(list
'(1.0 0.0 0.0 0.0)
'(0.0 1.0 0.0 0.0)
'(0.0 0.0 1.0 0.0)
(append (mapcar '- bl_wcs_list) '(1.0))
);list
mt_4x4_wcs2_list (apply 'mapcar (cons 'list mt_4x4_wcs1_list))
);setq
;; <!-- Create block
(if (not (tblsearch "BLOCK" file_name_str))
(progn
;; Block does not exist.
(setq col_Block_area (vlax-invoke-method col_Blocks 'Add (vlax-3D-point '(0.0 0.0 0.0)) file_name_str))
(vlax-put-property col_Block_area 'BlockScaling acUniform)
(vlax-put-property col_Block_area 'Explodable :vlax-true)
(vlax-put-property col_Block_area 'Units (getvar 'INSUNITS))
(setq objects2_var (vlax-invoke-method obj_AD 'CopyObjects objects1_sa col_Block_area nil)
objects2_list (vlax-safearray->list (vlax-variant-value objects2_var))
);setq
(foreach fe__object2 objects2_list
(vlax-invoke-method fe__object2 'TransformBy (vlax-tmatrix mt_4x4_wcs2_list))
);fe__object2
(vlax-release-object col_Block_area)
(princ "\nFile block created: ") (prin1 file_name_str)
);progn
);if
;; Create block -->
;; <!-- WBlock using Command Line Script
(vl-cmdf "_.EXPORT" file_fqn file_name_str)
;; WBlock using Command Line Script -->
);
);cond
(vlax-release-object fe__obj_polyline)
);fe__obj_polyline
(vlax-release-object col_Blocks)
(vlax-release-object obj_ACAD)
(vlax-release-object obj_AD)
);ss_polylines
);cond
(princ)
);c:wbfileblock
;;------------------------------------------------------------------------------
(princ "\nWBFileBlock loaded. Start command with WBFILEBLOCK.")
(princ)
Regards,
Trevor Bird
