;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Title : VP Scale
;; Purpose : To Place Scale bar & scale text
;; Written : Bijoy.v.m,
;; Web page : http://www.cadlispandtips.blogspot.com
;; Command : sb, sbb & sca
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;------------------sub function error------------------------

(defun trap1 (errmsg)
(setvar "clayer" clay)
(setvar "dimzin" di)
(setvar "attdia" ad)
(setvar "attreq" aq)
(command "undo" "end")
(setq *error* temperr)
(prompt "\n© Bijoy.v.m 2011 http://www.cadlispandtips.blogspot.com")
(princ)
) ;defun

;;---------------------Create Blocks---------------------------

(defun SBC(/ osm ssblk x y z )

(setq osm (getvar "OSMODE"))
(setvar "OSMODE" 0)
(setvar "attdia" 0)
(setvar "attreq" 1)

(if (not (tblsearch "block" "Scale-B"))
(progn
(setq ssblk (ssadd))

; Set Dimensions
(setq X 100) ; set horizontal dimension
(setq Y 2) ; set Vertical dimension

; Draw Function
(setq Z 0)

; Rectangle
(command "RECTANG" (list z z z)(list x y z))
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list z (* y 0.5) z)(list x (* y 0.5) z) "")
(setq ssblk (ssadd (entlast) ssblk))

; Soild Hatches
(command "SOLID" (list z z z)(list z (* y 0.5) z)(list (* x 0.02) z z)(list (* x 0.02) (* y 0.5) z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.02) (* y 0.5) z)(list (* x 0.02) y z)(list (* x 0.04) (* y 0.5) z)(list (* x 0.04) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.04) (* y 0.5) z)(list (* x 0.04) z z)(list (* x 0.06) (* y 0.5) z)(list (* x 0.06) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.06) (* y 0.5) z)(list (* x 0.06) y z)(list (* x 0.08) (* y 0.5) z)(list (* x 0.08) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.08) (* y 0.5) z)(list (* x 0.08) z z)(list (* x 0.1) (* y 0.5) z)(list (* x 0.1) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.1) (* y 0.5) z)(list (* x 0.1) y z)(list (* x 0.15) (* y 0.5) z)(list (* x 0.15) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.15) (* y 0.5) z)(list (* x 0.15) z z)(list (* x 0.2) (* y 0.5) z)(list (* x 0.2) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.2) (* y 0.5) z)(list (* x 0.2) y z)(list (* x 0.3) (* y 0.5) z)(list (* x 0.3) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.3) (* y 0.5) z)(list (* x 0.3) z z)(list (* x 0.4) (* y 0.5) z)(list (* x 0.4) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.4) (* y 0.5) z)(list (* x 0.4) y z)(list (* x 0.6) (* y 0.5) z)(list (* x 0.6) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.6) (* y 0.5) z)(list (* x 0.6) z z)(list (* x 0.8) (* y 0.5) z)(list (* x 0.8) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.8) (* y 0.5) z)(list (* x 0.8) y z)(list x (* y 0.5) z)(list x y z)"")
(setq ssblk (ssadd (entlast) ssblk))

; Lines
(command "LINE" (list (* x 0.02) y z)(list (* x 0.02) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.04) y z)(list (* x 0.04) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.06) y z)(list (* x 0.06) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.08) y z)(list (* x 0.08) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.1) y z)(list (* x 0.1) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.15) y z)(list (* x 0.15) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.2) y z)(list (* x 0.2) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.3) y z)(list (* x 0.3) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.4) y z)(list (* x 0.4) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.5) y z)(list (* x 0.5) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.6) y z)(list (* x 0.6) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.7) y z)(list (* x 0.7) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.8) y z)(list (* x 0.8) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.9) y z)(list (* x 0.9) z z) "")
(setq ssblk (ssadd (entlast) ssblk))

; Attribute texts
(if (not (tblsearch "style" "Gen-Text")) (command "-style" "Gen-Text" "Arial.ttf" 2.5 "1" 0 "n" "n"))

(Command "-attdef" "" "S" "Scale" "1:1000" "S" "Gen-Text" "J" "TL" (list z (- z 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "L" "L" "100m" "S" "Gen-Text" "J" "C" (list x (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "0" "L x 0.0" "0" "S" "Gen-Text" "J" "C" (list z (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "1" "L x 0.1" "10" "S" "Gen-Text" "J" "C" (list (* x 0.1) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "2" "L x 0.2" "20" "S" "Gen-Text" "J" "C" (list (* x 0.2) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "3" "L x 0.3" "30" "S" "Gen-Text" "J" "C" (list (* x 0.3) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "4" "L x 0.4" "40" "S" "Gen-Text" "J" "C" (list (* x 0.4) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "5" "L x 0.6" "60" "S" "Gen-Text" "J" "C" (list (* x 0.6) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "6" "L x 0.8" "80" "S" "Gen-Text" "J" "C" (list (* x 0.8) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))

(setq ssblk (ssadd (entlast) ssblk))
(Command "CHPROP" ssblk "" "LA" "0" "")
(Command "CHPROP" ssblk "" "LW" "0.13" "")
(Command "CHPROP" ssblk "" "C" "7" "")
(Command "CHPROP" ssblk "" "LT" "Continuous" "")

(command "-BLOCK" "Scale-B" (list (* x 0.5) z z) ssblk "") ; create block

) ;progn
) ;if

;;;--- to disable allow explod-----

(vl-load-com)
(setq BLOCKS
(vla-get-Blocks
(vla-get-activedocument
(vlax-get-acad-object)
)
)
BLK (vla-Item BLOCKS "Scale-B")
)
(vla-put-explodable (vla-Item BLOCKS "Scale-B") :vlax-false)

;;;--- end to disable allow explod-----

(setvar "OSMODE" osm)
(princ)
) ;defun

;---------------------------------Sub function Scale-B end--------------------------------

(defun CSBS(/ osm ssblk x y z )

(setq osm (getvar "OSMODE"))

(setvar "OSMODE" 0)
(setvar "attdia" 0)
(setvar "attreq" 1)

(if (not (tblsearch "block" "Scale-S"))
(progn
(setq ssblk (ssadd))

; Set Dimensions

(setq X 100) ; set horizontal dimension
(setq Y 2) ; set Vertical dimension

; Draw Function
(setq Z 0)

; Rectangle
(command "RECTANG" (list z z z)(list (* x 0.5) y z))
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list z (* y 0.5) z)(list (* x 0.5) (* y 0.5) z) "")
(setq ssblk (ssadd (entlast) ssblk))

; Soild Hatches
(command "SOLID" (list z z z)(list z (* y 0.5) z)(list (* x 0.02) z z)(list (* x 0.02) (* y 0.5) z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.02) (* y 0.5) z)(list (* x 0.02) y z)(list (* x 0.04) (* y 0.5) z)(list (* x 0.04) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.04) (* y 0.5) z)(list (* x 0.04) z z)(list (* x 0.06) (* y 0.5) z)(list (* x 0.06) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.06) (* y 0.5) z)(list (* x 0.06) y z)(list (* x 0.08) (* y 0.5) z)(list (* x 0.08) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.08) (* y 0.5) z)(list (* x 0.08) z z)(list (* x 0.1) (* y 0.5) z)(list (* x 0.1) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.1) (* y 0.5) z)(list (* x 0.1) y z)(list (* x 0.15) (* y 0.5) z)(list (* x 0.15) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.15) (* y 0.5) z)(list (* x 0.15) z z)(list (* x 0.2) (* y 0.5) z)(list (* x 0.2) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.2) (* y 0.5) z)(list (* x 0.2) y z)(list (* x 0.3) (* y 0.5) z)(list (* x 0.3) y z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.3) (* y 0.5) z)(list (* x 0.3) z z)(list (* x 0.4) (* y 0.5) z)(list (* x 0.4) z z)"")
(setq ssblk (ssadd (entlast) ssblk))
(command "SOLID" (list (* x 0.4) (* y 0.5) z)(list (* x 0.4) y z)(list (* x 0.5) (* y 0.5) z)(list (* x 0.5) y z)"")
(setq ssblk (ssadd (entlast) ssblk))

; Lines
(command "LINE" (list (* x 0.02) y z)(list (* x 0.02) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.04) y z)(list (* x 0.04) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.06) y z)(list (* x 0.06) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.08) y z)(list (* x 0.08) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.1) y z)(list (* x 0.1) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.15) y z)(list (* x 0.15) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.2) y z)(list (* x 0.2) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.3) y z)(list (* x 0.3) z z) "")
(setq ssblk (ssadd (entlast) ssblk))
(command "LINE" (list (* x 0.4) y z)(list (* x 0.4) z z) "")
(setq ssblk (ssadd (entlast) ssblk))

; Attribute texts
(if (not (tblsearch "style" "Gen-Text")) (command "-style" "Gen-Text" "Arial.ttf" 2.5 "1" 0 "n" "n"))

(Command "-attdef" "" "S" "Scale" "1:1000" "S" "Gen-Text" "J" "TL" (list z (- z 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "L" "L" "50m" "S" "Gen-Text" "J" "C" (list (* x 0.5) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "0" "L x 0.0" "0" "S" "Gen-Text" "J" "C" (list z (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "1" "L x 0.2" "10" "S" "Gen-Text" "J" "C" (list (* x 0.1) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "2" "L x 0.4" "20" "S" "Gen-Text" "J" "C" (list (* x 0.2) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "3" "L x 0.6" "30" "S" "Gen-Text" "J" "C" (list (* x 0.3) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))
(Command "-attdef" "" "4" "L x 0.8" "40" "S" "Gen-Text" "J" "C" (list (* x 0.4) (+ y 1) z) "0")
(setq ssblk (ssadd (entlast) ssblk))

(setq ssblk (ssadd (entlast) ssblk))
(Command "CHPROP" ssblk "" "LA" "0" "")
(Command "CHPROP" ssblk "" "LW" "0.13" "")
(Command "CHPROP" ssblk "" "C" "7" "")
(Command "CHPROP" ssblk "" "LT" "Continuous" "")

(command "-BLOCK" "Scale-S" (list (* x 0.25) z z) ssblk "") ; create block

) ;progn
) ;if

;;;--- to disable allow explod-----

(vl-load-com)
(setq BLOCKS
(vla-get-Blocks
(vla-get-activedocument
(vlax-get-acad-object)
)
)
BLK (vla-Item BLOCKS "Scale-S")
)
(vla-put-explodable (vla-Item BLOCKS "Scale-S") :vlax-false)

;;;--- end to disable allow explod-----

(setvar "OSMODE" osm)

(princ)
) ;defun

;-------------------sub function dwgscale--------------------

(defun getx (n data)
(nth n (cdadr (assoc -3 data)))
)
;---main function---

(defun DwgScale (/ data vse vht)

(cond
((not (equal 2 (getvar "lunits")))
)

(T
(acet-error-init
(list
(list "cmdecho" 0
"luprec" (getvar "luprec")
"dimzin" 8
)
T

) ;list
) ;acet-error-init

(cond
((and
ent
(setq data (entget ent '("ACAD")))
(= "VIEWPORT" (acet-dxf 0 DATA))
) ;and
(setq vht (acet-dxf 41 DATA)
vse (cdr (getx 6 data))
)

(prompt "\nVport Scale = ")

;--- for system preview ----
(cond
((< vse vht)
(princ "1:")
(princ (rtos (/ 1000 (/ vht vse)) 2))
; (princ ", Scale A3 = 1:")
; (princ (rtos (* 2 (/ 1000 (/ vht vse))) 2))
(princ " (Units are in Metre)")

)
(T (princ "1:")
(princ (rtos (* 1000 (/ vse vht)) 2))
; (princ ", Scale A3 = 1:")
; (princ (rtos (* 2 (* 1000 (/ vse vht))) 2))
(princ " (Units are in Metre)")
)
) ;cond

;--- string txt for scale text ----
(cond
((< vse vht)

(setq txt (strcat "SCALE 1:"(rtos (/ 1000 (/ vht vse)) 2 0) ))
)

(T
(setq txt (strcat "SCALE 1:"(rtos (* 1000 (/ vse vht)) 2 0) ))
)
) ;cond

;--- string vpa for scale bar ----
(cond
(( dec 2) (alert "\nCommand will work only in Decimal Units"))
(( uni 6) (alert "\nOnly Metre Units Accepted"))
(( dec 2) (alert "\nOnly Decimal Units Accepted"))
(( uni 6) (alert "\nOnly Metre Units Accepted"))
(( dec 2) (alert "\nOnly Decimal Units Accepted"))
(( uni 6) (alert "\nOnly Metre Units Accepted"))
((< uni 6) (alert "\nOnly Metre Units Accepted"))

) ;cond

(princ)
) ;defun

(prompt "\nVP Scale Commands : SB(Half length), SBB(Full Length), SCA(Scale Text)")
(c:sbb)

;;---------------------------------END---------------------------------

Advertisements