Topic: scale image from center

[PM]

Hi i use this code to scale images in layout for specific scales. The problem is that when i do the scale the image moves. Is it possible to scale from the center ?

Code - Auto/Visual Lisp: [Select]

1.  
2. (defun c:myimgscale (/)
3.  (TEXTPAGE)
4.  
5.  (princ "\n")(princ "\n")(princ "\n")
6. (progn
7.            (initget "1 2 3")
8.            (setq
9.              l
10.               (cond
11.                 ((getkword
12.                    "\nslelect image 1:1 :
13.                        1. for scale 1:500.
14.                        2. for scale 1:1000.
15.                        3. for scale 1:5000.
16. "
17.                  )
18.                 )
19.                 ("1")
20.               )
21.            )
22.  
23. (if (eq l "1")
24.          ((lambda (/ ent)
25.            (while (not (setq ent (car (entsel)))))
26.            (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 2)
27.             );end wile
28.          ); end lambda
29.        ); end if
30.        (if (eq l "2")
31.          ((lambda (/ ent)
32.            (while (not (setq ent (car (entsel)))))
33.            (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 1)
34.             );end wile
35.          ); end lambda
36.        ); end if
37.          ((lambda (/ ent)
38.            (while (not (setq ent (car (entsel)))))
39.            (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 0.2)
40.             );end wile
41.          ); end lambda
42.        ); end if
43.  
44. ) ; end if
45.  
46.  

Thanks

[ribarm]

Calculate center point and then provide that point to scale command...

[PM]

I find a Lee Mac code.

Code - Auto/Visual Lisp: [Select]

1. ;; Scale About Center  -  Lee Mac
2.  
3. (defun c:sac ( / ll sel obj ur )
4.    (initget 6)
5.    (if
6.        (and
7.            (setq *scl*
8.                (cond
9.                    (   (getdist (strcat "\nSpecify Scale Factor" (if *scl* (strcat " <" (rtos *scl* 2) ">: ") ": "))))
10.                    (   *scl*   )
11.                )
12.            )
13.            (ssget "_:L")
14.        )
15.        (progn
16.            (vlax-for obj (setq sel (vla-get-activeselectionset (vla-get-activedocument (vlax-get-acad-object))))
17.                (if (null (vl-catch-all-error-p (vl-catch-all-apply 'vla-getboundingbox (list obj 'll 'ur))))
18.                    (vla-scaleentity obj
19.                        (vlax-3D-point
20.                            (mapcar '(lambda ( a b ) (/ (+ a b) 2.0))
21.                                (vlax-safearray->list ll)
22.                                (vlax-safearray->list ur)
23.                            )
24.                        )
25.                        *scl*
26.                    )
27.                )
28.            )
29.            (vla-delete sel)
30.        )
31.    )
32.    (princ)
33. )
34. (vl-load-com) (princ)
35.  
36.  

can any one help to add this option menu with the specific scales from the previous code?

Code - Auto/Visual Lisp: [Select]

1.  (TEXTPAGE)
2.  
3.  (princ "\n")(princ "\n")(princ "\n")
4. (progn
5.            (initget "1 2 3")
6.            (setq
7.              l
8.               (cond
9.                 ((getkword
10.                    "\nslelect image 1:1 :
11.                       1. for scale 1:500.
12.                       2. for scale 1:1000.
13.                       3. for scale 1:5000.
14. "
15.                  )
16.                 )
17.                 ("1")
18.               )
19.            )
20.  
21.  

Thanks

[BIGAL]

Try this it will make a dcl for you look at ans. There is examples at the top of the code, perfect for this type of "please choose".

Code: [Select]

(if (not AH:Butts)(load "Multi Radio buttons.lsp"))
(if (not but)(setq but 1))
(setq ans  (ah:butts but "V"   '("Choose scale 1:X " "  100" "  200" "  300" "  400" "  500" )))


[PM]

HI BIGAL. i confused now. Can any one do the changes in post 3 ?

Thanks

[PM]

I find and this code for center scale

Code - Auto/Visual Lisp: [Select]

1. ;;  ScaleAboutCenters.lsp [command name: SAC]
2. ;;  To Scale multiple objects, each About its own Center, by the same User-specified
3. ;;    scale factor.
4. ;;  Uses the middle of each object's bounding box as the base point for scaling, to
5. ;;    keep objects centered at approximately the same position in the drawing.
6. ;;    [For Mtext, that will be based on the defined Mtext box width, not the extents
7. ;;    of the content; for a Block or Text, the center of its extents in the drawing, not
8. ;;    its insertion point; for an Arc, the center of its extents, not its geometric center;
9. ;;    some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
10. ;;    its extents and affect results slightly.]
11. ;;  Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
12. ;;  Stores scale factor; offers as default on subsequent use in same editing session.
13. ;;  Kent Cooper, 6 May 2014
14.  
15. (defun C:SAC (/ *error* cmde ss inc ent)
16.   (defun *error* (errmsg)
17.     (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
18.       (princ (strcat "\nError: " errmsg))
19.     ); end if
20.     (command "_.undo" "_end")
21.     (setvar 'cmdecho cmde)
22.     (princ)
23.   ); end defun - *error*
24.   (setq cmde (getvar 'cmdecho))
25.   (setvar 'cmdecho 0)
26.   (command "_.undo" "_begin")
27.   (setq *SACscl
28.     (cond
29.       ( (getreal
30.           (strcat
31.             "\nEnter Scale Factor <"
32.             (if *SACscl (rtos *SACscl 2 4) "1"); offer default: prior value / 1 on first use
33.             ">: "
34.           ); strcat
35.         ); getreal
36.       ); User-input condition
37.       (*SACscl); Enter on subsequent use [prior value]
38.       (1); Enter on first use
39.     ); cond & *SACscl
40.     ss (ssget ":L" '((-4 . "<NOT") (0 . "RAY,XLINE") (-4 . "NOT>")))
41.       ;; not objects on Locked Layers or without finite extents
42.   ); setq
43.   (repeat (setq inc (sslength ss))
44.     (setq ent (ssname ss (setq inc (1- inc))))
45.     (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
46.     (command
47.       ".scale" ent "" "_none"
48.       (mapcar '/ ; midpoint of bounding box
49.         (mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
50.         '(2 2 2)
51.       ); mapcar
52.       *SACscl
53.     ); command
54.   ); repeat
55.   (command "_.undo" "_end")
56.   (setvar 'cmdecho cmde)
57.   (princ)
58. ); defun
59. (vl-load-com)
60. (prompt "\nType SAC to Scale objects About each one's Center.")
61.  

[BIGAL]

This replaces all the (setq *SACscl code 27-42 just add more scales as you want.

Code: [Select]

(if (not AH:Butts)(load "Multi Radio buttons.lsp"))
(if (not but)(setq but 1))
(setq *SACscl (atof (ah:butts but "V"   '("Choose scale 1:X " "  1" "  500" "  1000" "  2000" "  5000" ))))
(setq ss (ssget ":L" '((-4 . "<NOT") (0 . "RAY,XLINE") (-4 . "NOT>"))))
      ;; not objects on Locked Layers or without finite extents



[PM]

Hi BIGAL. I prefer to convert 

this

Code - Auto/Visual Lisp: [Select]

1. (defun c:myimgscale (/)
2.  (TEXTPAGE)
3.  
4.  (princ "\n")(princ "\n")(princ "\n")
5. (progn
6.            (initget "1 2 3")
7.            (setq
8.              l
9.               (cond
10.                 ((getkword
11.                    "\nslelect image 1:1 :
12.                       1. for scale 1:500.
13.                       2. for scale 1:1000.
14.                       3. for scale 1:5000.
15. "
16.                  )
17.                 )
18.                 ("1")
19.               )
20.            )
21.  
22. (if (eq l "1")
23.          ((lambda (/ ent)
24.            (while (not (setq ent (car (entsel)))))
25.            (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 2)
26.             );end wile
27.          ); end lambda
28.        ); end if
29.        (if (eq l "2")
30.          ((lambda (/ ent)
31.            (while (not (setq ent (car (entsel)))))
32.            (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 1)
33.             );end wile
34.          ); end lambda
35.        ); end if
36.          ((lambda (/ ent)
37.            (while (not (setq ent (car (entsel)))))
38.            (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 0.2)
39.             );end wile
40.          ); end lambda
41.        ); end if
42.  
43. ) ; end if
44.  
45.  

with

Code - Auto/Visual Lisp: [Select]

1.     ;;  ScaleAboutCenters.lsp [command name: SAC]
2.     ;;  To Scale multiple objects, each About its own Center, by the same User-specified
3.     ;;    scale factor.
4.     ;;  Uses the middle of each object's bounding box as the base point for scaling, to
5.     ;;    keep objects centered at approximately the same position in the drawing.
6.     ;;    [For Mtext, that will be based on the defined Mtext box width, not the extents
7.     ;;    of the content; for a Block or Text, the center of its extents in the drawing, not
8.     ;;    its insertion point; for an Arc, the center of its extents, not its geometric center;
9.     ;;    some entity types' (e.g. Spline's) bounding box can sometimes reach beyond
10.     ;;    its extents and affect results slightly.]
11.     ;;  Rejects selection of objects on locked Layers, or without a "center" [Rays, Xlines].
12.     ;;  Stores scale factor; offers as default on subsequent use in same editing session.
13.     ;;  Kent Cooper, 6 May 2014
14.      
15.     (defun C:SAC (/ *error* cmde ss inc ent)
16.       (defun *error* (errmsg)
17.         (if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
18.           (princ (strcat "\nError: " errmsg))
19.         ); end if
20.         (command "_.undo" "_end")
21.         (setvar 'cmdecho cmde)
22.         (princ)
23.       ); end defun - *error*
24.       (setq cmde (getvar 'cmdecho))
25.       (setvar 'cmdecho 0)
26.       (command "_.undo" "_begin")
27.       (setq *SACscl
28.         (cond
29.           ( (getreal
30.               (strcat
31.                 "\nEnter Scale Factor <"
32.                 (if *SACscl (rtos *SACscl 2 4) "1"); offer default: prior value / 1 on first use
33.                 ">: "
34.               ); strcat
35.             ); getreal
36.           ); User-input condition
37.           (*SACscl); Enter on subsequent use [prior value]
38.           (1); Enter on first use
39.         ); cond & *SACscl
40.         ss (ssget ":L" '((-4 . "<NOT") (0 . "RAY,XLINE") (-4 . "NOT>")))
41.           ;; not objects on Locked Layers or without finite extents
42.       ); setq
43.       (repeat (setq inc (sslength ss))
44.         (setq ent (ssname ss (setq inc (1- inc))))
45.         (vla-getboundingbox (vlax-ename->vla-object ent) 'minpt 'maxpt)
46.         (command
47.           ".scale" ent "" "_none"
48.           (mapcar '/ ; midpoint of bounding box
49.             (mapcar '+ (vlax-safearray->list minpt) (vlax-safearray->list maxpt))
50.             '(2 2 2)
51.           ); mapcar
52.           *SACscl
53.         ); command
54.       ); repeat
55.       (command "_.undo" "_end")
56.       (setvar 'cmdecho cmde)
57.       (princ)
58.     ); defun
59.     (vl-load-com)
60.     (prompt "\nType SAC to Scale objects About each one's Center.")
61.      
62.  

Thanks

[BIGAL]

A hidden part of the multi radio button is look at variable BUT it is which button number is picked so you can have your 1. 1:1, 2. 1:200

Just do the code above then type !but you will see a number appear that matches the button picked. You dont need the (setq ans if you use the but value.

(ah:butts but "V"   '("Choose scale 1:X " "1.  1" "2.  500" "3.  1000" "4.   2000" "5.   5000" ))

Also

Code: [Select]

(while (not (setq ent (car (entsel "\npick entity ")))))
(cond
     ((= but 1)        (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 1.0))
     ((= but 2)        (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 2.0))
     ((= but 3)        (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 0.2))    
)


[PM]

 BIGAL i want to ask something. When i choose a scale the window close before i press OK  is it possible to fix it?

Code - Auto/Visual Lisp: [Select]

1. (defun c:test (/)
2.  
3. (if (not AH:Butts)(load "Multi Radio buttons.lsp"))
4. (if (not but)(setq but 1))
5. (setq *testscl (atof (ah:butts but "V"   '("Choose scale 1:X" "1.  1:500" "2.  1:1000" "3.  1:5000"))))
6.  
7.  
8.  
9. (while (not (setq ent (car (entsel "\npick entity ")))))
10. (cond
11.      ((= but 1)        (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 2.0))
12.      ((= but 2)        (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 1.0))
13.      ((= but 3)        (command "_scale" ent "" (cdr (assoc 11 (entget ent))) 0.2))        
14. )      
15. )
16.  
17. ; Multi button Dialog box for a single choice repalcment of initget
18. ; By Alan H Feb 2019 info@alanh.com.au
19.  
20. ; Example code as the radio button click will close the default button setting is required
21. ; It will remember what button ws pressed if ran again with same request.
22. ; You can have "H" horizontal or "V" vertical for DCL.
23.  
24.  
25. ; a=97 A=65 1=49 0=48
26. ; example make an options list a-h 97 then 8 more.
27. ; (if (not AH:Butts)(load "Multi Radio buttons.lsp"))
28. ; (if (not but)(setq but 1))
29. ; (setq ans2 (ah:butts 1 "v"  (make_letters "Please choose" 97 8)))
30.  
31.  
32. ; (if (not AH:Butts)(load "Multi radio buttons.lsp"))           ; loads the program if not loaded already
33. ; (if (not but)(setq but 1))                            ; this is needed to set default button
34.                                                 ; you can reset default button to user pick
35. ; (if (not AH:Butts)(load "Multi Radio buttons.lsp"))
36. ; (if (not but)(setq but 1))
37. ; (setq ans (substr  (ah:butts but "V"   '("Choose colour to remain " "  1" "  2" "  3" "  4" "  5" "  6" "  7")) ))
38. ; spaced characters
39. ; or just use "but" value and compare to a list
40. ; ans holds the button picked value as a string
41.                                                                         ; if you want ans a number use (atof ans) or (atoi ans)
42.  
43. ;(if (not AH:Butts)(load "Multi Radio buttons.lsp"))
44. ;(if (= but nil)(setq but 1))
45. ;(setq ans (ah:butts but "h"  '("Yes or No" "Yes" "No"))) ; ans holds the button picked value
46.  
47.  
48. ; (if (not AH:Butts)(load "Multi Radio buttons.lsp"))
49. ; (if (= but nil)(setq but 1))
50. ; (setq ans (atoi(ah:butts but "V" '("Choose a number" "1" "2" "3" "4" "5" "6" "7" "8" "9" "10")))) ; ans holds the button picked as an integer value
51.  
52. (defun make_letters (heading  asc numch  / lstchar)
53. (if (/= heading nil)(setq lstchar (list heading))(setq lstchar '()))
54. (repeat numch
55. (setq lstchar (cons (chr asc) lstchar))
56. (setq asc (+ asc 1))
57. )
58. (setq lstchar (reverse lstchar))
59. (princ lstchar)
60. )
61.  
62. (defun AH:Butts (AHdef verhor butlst / fo fname x  k numch asc)
63. (setq fo (open (setq fname (vl-filename-mktemp "" "" ".dcl")) "w"))
64. ;(setq fo (open (setq fname "D:\\acadtemp\\test.dcl") "w"))
65. (write-line  "AHbutts : dialog  {" fo)
66. (write-line  (strcat "  label =" (chr 34) (nth 0 butlst) (chr 34) " ;" )fo)
67. (write-line "   : row   {" fo)
68. (if (=  (strcase verhor) "V")
69. (progn
70. (write-line "   : boxed_radio_column    {" fo)
71. (write-line  (strcat " width = " (rtos (+ (strlen (nth 0 butlst)) 10) 2 0) " ;")  fo)           ; increase 10 if label does not appear
72. )
73. (write-line "   : boxed_radio_row       {" fo)
74. )
75. (setq x 1)
76. (setq numch (length butlst))
77. (repeat (- numch 1)
78. (write-line "   : radio_button  {" fo)
79. (write-line  (strcat "key = "  (chr 34) "Rb" (rtos x 2 0)  (chr 34) ";") fo)
80. (write-line  (strcat "label = " (chr 34) (nth x  butlst) (chr 34) ";") fo)
81. (write-line "   }" fo)
82. ;(if (or (= numch nil) (< numch 8))
83. (write-line "spacer_1 ;" fo)
84. ;)
85. (setq x (+ x 1))
86. )
87. (write-line "   }" fo)
88. (write-line "   }" fo)
89. (write-line "spacer_1 ;" fo)
90. (write-line "   ok_only;" fo)
91. (write-line "   }" fo)
92. (close fo)
93. (setq dcl_id (load_dialog fname))
94. (if (not (new_dialog "AHbutts" dcl_id) )
95. (exit)
96. )
97. (setq x 1)
98. (repeat (- (length butlst) 1)
99. (setq k (strcat "Rb" (rtos x 2 0)))
100. (action_tile k  (strcat "(setq but "  (rtos x 2 0) ")" "(done_dialog)"))
101. (if (= ahdef x)(set_tile k "1"))
102. (setq x (+ x 1))
103. )
104. (action_tile "accept" (strcat "(setq but "  (rtos ahdef 2 0) ")" "(done_dialog)"))
105. (start_dialog)
106. (unload_dialog dcl_id)
107. (vl-file-delete fname)
108. (nth but butlst)
109.  
110. ) ; end defun
111.  
112.  
113.  
114.  

Thanks

[BIGAL]

I wrote it that way its a single pick answer that is a rule with Radio Buttons, it resets which button is high lighted so when run again and want same button would just pick OK.

You only need the 3 lines of code for it to work the (if (not AH:Butts)(load "Multi Radio buttons.lsp")) will load the code automatically from a directory, 2 methods make sure Multi Radio Buttons.lsp is saved in a "Support" directory. Or change the load to full path eg (load "d:\\alan\\lisps\\Multi radio buttons.lsp") so it does not need to live in your code.

You can use the if not on other providers a good example is the excellent code provided  by Lee-mac.com.
(if (not LM:readcsv)(load "Readcsv-V1-3"))