Jump to content

Default setting aerial survey


Gentile Romano

Recommended Posts

Hi guys,

After a long time . . .

Could anyone help me out to figure out

 

(setq blkLyrScaList '(("BLOCK1" "LAYER1" "250" "250" "1") ("BLOCK2" "LAYER2" "500" ""500 "1") ("BLOCK3" "LAYER3" "150" ""150 "1") ("BLOCK4" "LAYER4" "100" ""100 "1")))

Exam:
All BLOCK1 should move to layer1 then
setpropertyvalue X to 250
setpropertyvalue Y to 250
setpropertyvalue Z to 1 

Link to comment
Share on other sites

This will get you started. do what you want. Scales from the insertion point of the block.

 

(defun c:BLKSCALE (/ blklst SS obj ed)
  (setq blklst '(("BLOCK1" "LAYER1" 250 250) ("BLOCK2" "LAYER2" 500 500) 
                 ("BLOCK3" "LAYER3" 150 150) ("BLOCK4" "LAYER4" 100 100))
  )
  (foreach ent blklst
    (setq blkname (car ent) ent (cdr ent))
    (if (setq SS (ssget "_X" (list '(0 . "INSERT") (cons 2 blkname))))
      (foreach blk (mapcar 'cadr (ssnamex SS))
        (setq ed (entget blk)
              ed (subst (cons 8 (car ent)) (assoc 8 ed) ed)
              ed (subst (cons 41 (cadr ent))(assoc 41 ed) ed)
              ed (subst (cons 42 (caddr ent)) (assoc 42 ed) ed)
              ed (subst (cons 43 1) (assoc 43 ed) ed)  ;This was always one so removed from list
        ) 
        (entmod ed) 
      )
    )
  )
  (princ)
)
Edited by mhupp
  • Thanks 1
Link to comment
Share on other sites

Just an extra to what Mhupp provided ignoring the number v's string you must check more carefully for typo's 

 

("BLOCK2" "LAYER2" "500" ""500 "1") 2 mistakes a double "" and a missing "

  • Agree 2
Link to comment
Share on other sites

11 hours ago, mhupp said:

This will get you started. do what you want. Scales from the insertion point of the block.

 

(defun c:BLKSCALE (/ blklst SS obj ed)
  (setq blklst '(("BLOCK1" "LAYER1" 250 250) ("BLOCK2" "LAYER2" 500 500) 
                 ("BLOCK3" "LAYER3" 150 150) ("BLOCK4" "LAYER4" 100 100))
  )
  (foreach ent blklst
    (setq blkname (car ent) ent (cdr ent))
    (if (setq SS (ssget "_X" (list '(0 . "INSERT") (cons 2 blkname))))
      (foreach blk (mapcar 'cadr (ssnamex SS))
        (setq ed (entget blk)
              ed (subst (cons 8 (car ent)) (assoc 8 ed) ed)
              ed (subst (cons 41 (cadr ent))(assoc 41 ed) ed)
              ed (subst (cons 42 (caddr ent)) (assoc 42 ed) ed)
              ed (subst (cons 43 1) (assoc 43 ed) ed)  ;This was always one so removed from list
        ) 
        (entmod ed) 
      )
    )
  )
  (princ)
)

That was amazing, thank you so much

Could you please slightly modify to shot layer color as i added

 

(defun c:BLKSCALE (/ blklst SS obj ed)
  (setq blklst '(("BLOCK1" "LAYER1" 100 100 10) ("BLOCK2" "LAYER2" 250 250 30) ("BLOCK3" "LAYER3" 150 150 210) ("BLOCK4" "LAYER4" 100 100 170)))
  (foreach ent blklst
    (setq blkname (car ent) ent (cdr ent))
    (if (setq SS (ssget "_X" (list '(0 . "INSERT") (cons 2 blkname))))
      (foreach blk (mapcar 'cadr (ssnamex SS))
        (setq ed (entget blk)
              ed (subst (cons 8 (car ent)) (assoc 8 ed) ed)
              ed (subst (cons 41 (cadr ent)) (assoc 41 ed) ed)
              ed (subst (cons 42 (caddr ent)) (assoc 42 ed) ed)
              ed (subst (cons 43 1) (assoc 43 ed) ed)) ;This was always one so removed from list
        (entmod ed) 
      )
    )
  ) (princ))


        (setq  ed (subst (cons 62 (xxxxxx ent)) (assoc 62 ed) ed))

(("BLOCK1" "LAYER1" 100 100 10) ("BLOCK2" "LAYER2" 250 250 30) ("BLOCK3" "LAYER3" 150 150 210) ("BLOCK4" "LAYER4" 100 100 170))

Edited by Gentile Romano
Link to comment
Share on other sites

Its not that simple to change the color of a Block. You have to change each sub entity I suggest changing them to bylayer (256) then setting the layer color to what you want. That way it changes automatically.

 

updated this lisp to use acad_colordlg

 

;****************************************************************************************
;   UPDATE BLOCK COLOR (updblkcl.lsp) 
;   PRE-INSERTED BLOCK DEFINITION CLEAN-UP UTILITY
; 
;   This routine is especially usefull to redefine pre-inserted blocks whose 
;   entity colors need to be changed to BYLAYER. 
; 
;   This routine allows the user to update the color of all entities within
;   a block to a single color (exam: color=BYLAYER) without the user 
;   having to explode the symbol.  By default the layer name of 
;   all entities are NOT changed. The routine changes the original 
;   definition of the block within the current drawing. 
; 
;   To use this routine the user is asked to specify a single 
;   color to place all entities of a selected block(s). 
; 
;   The user is next prompted to select one or more blocks to update. The routine 
;   then redefines all entities of the block to the color specified. 
; 
;   When the user regenerates the drawing she/he will find that all 
;   occurances of the block have been redefined.  This is because the 
;   original definition of the block is changed!!! 
; 
;       by CAREN LINDSEY, July 1996 
;****************************************************************************************
; 
;INTERNAL ERROR HANDLER

(defun err-ubc (s)       ; If an error (such as CTRL-C) occurs
  (if (/= s "Function cancelled")
    (princ (strcat "\nError: " s))
  )
  (setq *error* olderr)  ; Restore old *error* handler
  (princ)
)  ;err-ubc
(DEFUN C:BBL (/ BLK CBL CBL2 C ACL ALY NLY NCL)
  (vl-load-com)
  (setq olderr *error* *error* err-ubc)
  (setq C (acad_colordlg 0))
  (prompt "\nPick blocks to update. ")
  (setq SS (ssget '((0 . "INSERT"))))
  (setq K 0)
  (while (< K (sslength SS))
    (setq CBL (tblsearch "BLOCK" (cdr (assoc 2 (entget (setq BLK (ssname SS K)))))))
    (setq CBL2 (cdr (assoc -2 CBL)))
    (while (boundp 'CBL2)
      (setq EE (entget CBL2))
      (setq NCL (cons 62 C))
      (setq ACL (assoc 62 EE))
      (if (= ACL nil)
        (setq NEWE (append EE (list NCL)))
        (setq NEWE (subst NCL ACL EE))
      )  ;if
      (entmod NEWE)
      (setq CBL2 (entnext CBL2))
    )         ;end while
    (entupd BLK)
    (setq K (1+ K))
  )  ;end while
  (setq *error* olderr)
  (vla-Regen (vla-get-activedocument (vlax-get-acad-object)) acAllViewports)
  (princ)
)

 

Edited by mhupp
  • Agree 1
Link to comment
Share on other sites

(("BLOCK1" "LAYER1" 100 100 10) ("BLOCK2" "LAYER2" 250 250 30) ("BLOCK3" "LAYER3" 150 150 210) ("BLOCK4" "LAYER4" 100 100 170))

 

The layer1, Layer2 & Layer3 was creating newly, that color wants to change.

Link to comment
Share on other sites

If layer isn't there before command is run it will be created but with default settings. This will then change the layer to the correct color from your list. this is prob the best option with all block entity's color to byblock. the second lisp takes part of the updblkcl.lsp and changes entity's color in the block.

 

;entmod layer change color
(defun c:BLKSCALE (/ blklst lst blkname SS ent blk C CBL)
  (vl-load-com)
  (setq blklst '(( "BLOCK1" "LAYER1" 250 250 10) ( "BLOCK2" "LAYER2" 500 500 30)
                   ( "BLOCK3" "LAYER3" 150 150 210) ( "BLOCK4" "LAYER4" 100 100 170)
                )
  )
  (foreach lst blklst
    (setq blkname (car lst) lst (cdr lst))
    (if (setq SS (ssget "_X" (list '(0 . "INSERT") (cons 2 blkname))))
      (progn
        (foreach blk (mapcar 'cadr (ssnamex ss))
          (entmod
            (append (entget blk) (mapcar 'cons '(8 41 42 43) (list (car lst) (cadr lst) (caddr lst) 1)))
          )
        )
        (setq lay (entget (tblobjname "LAYER" (car lst))))
        (entmod (subst (cons 62 (last lst)) (assoc 62 lay) lay))
      )
    )
  )
  (vla-Regen (vla-get-activedocument (vlax-get-acad-object)) acAllViewports)
  (princ)
)

 

 

;endmod block change color
(defun c:BLKSCALE (/ blklst lst blkname SS ent blk C CBL)
  (vl-load-com)
  (setq blklst '(( "BLOCK1" "LAYER1" 250 250 10) ( "BLOCK2" "LAYER2" 500 500 30)
                   ( "BLOCK3" "LAYER3" 150 150 210) ( "BLOCK4" "LAYER4" 100 100 170)
                )
  )
  (foreach lst blklst
    (setq blkname (car lst) lst (cdr lst))
    (if (setq SS (ssget "_X" (list '(0 . "INSERT") (cons 2 blkname))))
      (progn
        (foreach blk (mapcar 'cadr (ssnamex ss))
          (entmod
            (append (entget blk) (mapcar 'cons '(8 41 42 43) (list (car lst) (cadr lst) (caddr lst) 1)))
          )
        )
        (setq C (last lst))
        (setq CBL (tblsearch "BLOCK" (cdr (assoc 2 (entget blk))))))
        (setq CBL2 (cdr (assoc -2 CBL)))
        (while (boundp 'CBL2)
          (setq EE (entget CBL2))
          (setq NCL (cons 62 C))
          (setq ACL (assoc 62 EE))
          (if (= ACL nil)
            (setq NEWE (append EE (list NCL)))
            (setq NEWE (subst NCL ACL EE))
          )         ;if
          (entmod NEWE)
          (setq CBL2 (entnext CBL2))
        )           ;end while
      )
    )
  )
  (vla-Regen (vla-get-activedocument (vlax-get-acad-object)) acAllViewports)
  (princ)
)

 

Edited by mhupp
update to ronjonp code
  • Like 1
Link to comment
Share on other sites

@mhupp FWIW
 

;; This
(foreach blk (mapcar 'cadr (ssnamex ss))
  (setq	ed (entget blk)
	ed (subst (cons 8 (car ent)) (assoc 8 ed) ed)
	ed (subst (cons 41 (cadr ent)) (assoc 41 ed) ed)
	ed (subst (cons 42 (caddr ent)) (assoc 42 ed) ed)
	ed (subst (cons 43 1) (assoc 43 ed) ed)
  )
  (entmod ed)
)
;; Can be written like this
(foreach blk (mapcar 'cadr (ssnamex ss))
  (entmod (append (entget blk)
		  (list (cons 8 (car ent)) (cons 41 (cadr ent)) (cons 42 (caddr ent)) (cons 43 1))
	  )
  )
)
;; Or this too :)
(foreach blk (mapcar 'cadr (ssnamex ss))
  (entmod
    (append (entget blk) (mapcar 'cons '(8 41 42 43) (list (car ent) (cadr ent) (caddr ent) 1)))
  )
)

Assuming I didn't fat finger something :)

  • Like 2
Link to comment
Share on other sites

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.
Note: Your post will require moderator approval before it will be visible.

Guest
Unfortunately, your content contains terms that we do not allow. Please edit your content to remove the highlighted words below.
Reply to this topic...

×   Pasted as rich text.   Restore formatting

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

×
×
  • Create New...