Change Height of user selected Texts similar to Height of selected “example” text


;;; Change Height of user selected Texts similar to Height of selected "example" text
;;; Based on Lee Mak Routine http://www.cadtutor.net/forum/showthread.php?97314-Lisp-to-change-text-height
;;; Modified by Igal Averbuh 2017 (added option to use height of selected "example" text)

(defun c:ct (/ ht ss)
(vl-load-com)

(setq ent (entget (car (entsel "\nClick on Text with needful height:"))))
(setq htt (cdr (assoc 40 ent)))

(if (and (setq ht (cdr (assoc 40 ent)))
(princ "\nSelect Texts to change it Height:")
(setq ss (ssget '((0 . "*TEXT")))))
(foreach x (mapcar 'entget
(vl-remove-if 'listp
(mapcar 'cadr (ssnamex ss))))
(entmod (subst (cons 40 ht) (assoc 40 x) x))))
(princ))
(c:ct)

Marko Ribar Dynamic ISOmetric Routine


;;; Marko Ribar Dynamic ISOmetric Routine
;;; Saved from: https://www.theswamp.org/index.php?topic=52655.0
(defun c:3d ( / massoclst pol1 pol2 bl lst1 lst2 lil p gr pp v lst2n )

(defun massoclst ( key lst )
(if (assoc key lst) (cons (assoc key lst) (massoclst key (cdr (member (assoc key lst) lst)))))
)

(setq pol1 (car (entsel "\nPick LWPOLYLINE...")))
(setq pol2 (entmakex (vl-remove-if (function (lambda ( x ) (vl-position (car x) '(-1 5 330)))) (entget pol1))))
(setq bl (massoclst 42 (entget pol2)))
(setq lst1 (mapcar 'cdr (massoclst 10 (entget pol1))))
(setq lst2 (mapcar 'cdr (massoclst 10 (entget pol2))))
(mapcar (function (lambda ( a b ) (setq lil (cons (entmakex (list '(0 . "LINE") (cons 10 a) (cons 11 b))) lil)))) lst1 lst2)
(setq lil (reverse lil))
(setq p (getpoint "\nPick or specify point : "))
(prompt "\nMove mouse and press \"+\" or \"-\" keys for scale and \"4\" or \"6\" for rotation... To finish left mouse click...")
(while (/= 3 (car (setq gr (grread t))))
(cond
( (and (= 2 (car gr)) (= 43 (cadr gr)))
(setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ pp (mapcar '* (mapcar '- x pp) (list (sqrt 2.0) (sqrt 2.0)))))) lst2n))
)
( (and (= 2 (car gr)) (= 45 (cadr gr)))
(setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ pp (mapcar '* (mapcar '- x pp) (list (/ (sqrt 2.0) 2.0) (/ (sqrt 2.0) 2.0)))))) lst2n))
)
( (and (= 2 (car gr)) (= 52 (cadr gr)))
(setq lst2n (mapcar (function (lambda ( x ) (polar pp (+ (angle pp x) (/ pi 4.0)) (distance pp x)))) lst2n))
)
( (and (= 2 (car gr)) (= 54 (cadr gr)))
(setq lst2n (mapcar (function (lambda ( x ) (polar pp (- (angle pp x) (/ pi 4.0)) (distance pp x)))) lst2n))
)
( t
(if (null pp)
(setq pp (cadr gr))
)
(setq v (mapcar '- pp p))
(if (null lst2n)
(setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ v x))) lst2))
(progn
(setq lst2n (mapcar (function (lambda ( x ) (mapcar '+ (mapcar '- (cadr gr) pp) x))) lst2n))
(setq pp (cadr gr))
)
)
)
)
(entmod (append (vl-remove-if (function (lambda ( x ) (vl-position (car x) '(10 42)))) (entget pol2)) (apply 'append (mapcar (function (lambda ( a b ) (list (cons 10 a) b))) lst2n bl))))
(mapcar (function (lambda ( a x ) (entmod (subst (cons 11 a) (assoc 11 (entget x)) (entget x))))) lst2n lil)
(redraw)
)
(princ)
)

(c:3d)

Using BigFonts..

Asian alphabets contain thousands of non-ASCII characters. To support such text, the program provides a special type of shape definition known as a Big Font file. You can set a style to use both regular and Big Font files.

Asian Language Big Fonts:
Font File Name

Description

@extfont2.shx

Japanese vertical font (a few characters are rotated to work correctly in vertical text)

bigfont.shx

Japanese font, subset of characters

chineset.shx

Traditional Chinese font

extfont.shx

Japanese extended font, level 1

extfont2.shx

Japanese extended font, level 2

gbcbig.shx

Simplified Chinese font

whgdtxt.shx

Korean font

whgtxt.shx

Korean font

whtgtxt.shx

Korean font

whtmtxt.shx

Korean font

When you specify fonts using the STYLE command, the assumption is that the first name is the normal font and the second (separated by a comma) is the Big Font. If you enter only one name, it’s assumed that it is the normal font and any associated Big Font is removed. By using leading or trailing commas when specifying the font file names, you can change one font without affecting the other, as shown in the following table.

Double-Byte Character Issues

Data Source Names
•Character codes (such as 0x??41 and 0x??61) that are used for data source names may not be handled correctly. This problem occurs when you create multiple data sources using optional names (Japanese) specified in the database configuration. As a result, some of the data source names may not be listed. When this problem occurs, you can change the name of the unlisted data source to another name.

Subobject and Object Cycling
•Subobject and object cycling using CTRL + SPACEBAR and SHIFT + SPACEBAR does not work in Chinese (PRC and Taiwan) versions of Microsoft Windows. When using the Chinese IME, these key combinations do the following: ◦CTRL + SPACEBAR toggles Chinese IME.
◦SHIFT + SPACEBAR toggles double-byte and single-byte English characters.

 

Text Display

Vertical Text for Asian Languages
•SHX fonts – Text can be created with SHX fonts and Big Fonts for vertical display in the same way as for previous releases. For best results, use the single-line TEXT command, not MTEXT. You can select a vertical style in the Text Style dialog box.

TrueType fonts – You still select fonts starting with the @ sign, but now the text is automatically rotated 270 degrees. (In AutoCAD 2005 and earlier versions, you had to manually rotate this text.) Vertical cursor movement is now supported for vertical text.

Font Display
•If the default font doesn’t support the characters you enter using the In-Place Text Editor (MTEXT command), an alternative font is usually substituted.
•CIF or MIF codes entered with the In-Place Text Editor (MTEXT command) or with the DTEXT command are now automatically converted to display the actual characters.

Updated bigfont.ini
•AutoCAD 2007 and AutoCAD 2008 are handling custom SHX Big Fonts differently than AutoCAD 2006 and earlier versions. If custom SHX Big Fonts are used in your drawing files, you need to add the SHX Big Font names and their code page ID into the bigfont.ini file in your Support folder. Please refer to the header section of this bigfont.ini file to learn how to add them.

Некоторые факторы влияют на выбор, ввод и представление на чертеже текста на разных языках.

Программа поддерживает стандарт кодирования символов Unicode. SHX-шрифт, закодированный с использованием шрифта стандарта Unicode, может содержать намного больше символов, чем описанный в системе пользователя; поэтому для использования символа, не доступного непосредственно с клавиатуры, можно ввести последовательность \U+nnnn, где nnnn представляет собой шестнадцатеричное значение Unicode для символа.

Начиная с версии AutoCAD 2007, все контурные SHX-шрифты кодируются с учетом стандарта Unicode, за исключением “Больших шрифтов”. При выборе шрифта для международных работ можно воспользоваться или шрифтом TrueType, или “Большим шрифтом”.

SHX-файлы азиатских “больших шрифтов”

Азиатские алфавиты содержат тысячи символов, не относящихся к стандарту ASCII. Для поддержки такого текста программа позволяет работать с особым типом файлов описания форм, называемых файлами большого шрифта. При этом текстовому стилю можно одновременно назначать обычный и большой шрифт.

Большие шрифты азиатских языков, входящие в продукт

Наименование файла шрифта

Описание

@extfont2.shx

Японский вертикальный шрифт (некоторые символы повернуты для корректного использования в вертикальном тексте)

bigfont.shx

Японский шрифт, подгруппа символов

chineset.shx

Традиционный китайский шрифт

extfont.shx

Расширенный японский шрифт, уровень 1

extfont2.shx

Расширенный японский шрифт, уровень 2

gbcbig.shx

Упрощенный китайский шрифт

whgdtxt.shx

Корейский шрифт

whgtxt.shx

Корейский шрифт

whtgtxt.shx

Корейский шрифт

whtmtxt.shx

Корейский шрифт

При вводе имен шрифтов в командной строке в ответ на запрос команды -СТИЛЬ предполагается, что первым вводится имя обычного шрифта, а вторым (через запятую) – имя большого шрифта. Если вводится только одно имя, предполагается, что это имя обычного шрифта, и любой связанный с ним большой шрифт удаляется из стиля. Вставляя запятые перед именами файлов шрифтов или после них, можно переназначить только один из шрифтов, не изменяя другой, как показано в следующей таблице.

Автокад поддерживает стандарт Unicode, при котором в шрифте может содержаться до 65 тыс. символов из различных языков, правда ввести такие символы непосредственно невозможно, приходится пользоваться последовательностями \U+nnnn, где nnnn – шестнадцатиричный код символа. Все AutoCAD SHX-шрифты являются Unicode. Предыдущие релизы Автокад вплоть до 13, не поддерживают эту возможность. Шрифты BIGFONT используются для представления символов алфавиты которых содержат тысячи “букв”. Пример изменения файла шрифтов:

Sub ChangeFontFiles()
    ThisDrawing.ActiveTextStyle.BigFontFile = "C:/AutoCAD/Fonts/bigfont.shx"
    ThisDrawing.ActiveTextStyle.fontFile = "C:/AutoCAD/Fonts/italic.shx"
End Sub

Make Lasso Selection (draw spline and Select Objects Within/Crossing it)


;;; Make Lasso Selection (draw spline and Select Objects Within/Crossing it)
;;; Created by Igal Averbuh 2017 (inspired by some ideas from http://www.cadtutor.net/forum/)
;;; Special thanks to Alan J. Thompson

(defun c:SWC (/ _pac add ss i e temp it o a b pts tempC i3 ec)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
(vl-load-com)

(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))) 100.))))
(while (< (setq d (+ d v)) l)
(setq lst (cons (vlax-curve-getPointAtDist e d) lst))
)
)

(initget 0 "Crossing Within")
(setq *SWC:Opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*SWC:Opt*)
)
)

(princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget "L"

)
)
(progn (repeat (setq i (sslength ss))
(if (setq temp (ssget "_WP" (_pac (setq e (ssname ss (setq i (1- i)))))))
(repeat (setq i2 (sslength temp)) (ssadd (ssname temp (setq i2 (1- i2))) add))
)

(if (eq *SWC:Opt* "Crossing")
(progn (vla-getboundingbox (setq o (vlax-ename->vla-object e)) 'a 'b)
(setq pts (mapcar 'vlax-safearray->list (list a b)))
(if (setq tempC (ssget "_C"
(list (caar pts) (cadar pts) 0.)
(list (caadr pts) (cadadr pts) 0.)
)
)
(repeat (setq i3 (sslength tempC))
(if (vlax-invoke
o
'Intersectwith
(vlax-ename->vla-object (setq ec (ssname tempC (setq i3 (1- i3)))))
acExtendNone
)
(ssadd ec add)
)
)
)
)
)
)
(sssetfirst nil add)
(ssget "_I")
)
)
(princ)
)

(defun C:LAS ()
(setvar "osmode" 16384)

(command "_.spline")
(while (> (getvar "CmdActive") 0)
(command pause)
)
(c:swc)
(princ)
)

Select Objects Within/Crossing Curve


(defun c:SWC (/ _pac add ss i e temp it o a b pts tempC i3 ec)
;; Select Objects Within/Crossing Curve
;; Alan J. Thompson, 03.31.11
;; Slightly modified by Igal Averbuh 2017 (added option for splines)
(vl-load-com)

(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))) 100.))))
(while (< (setq d (+ d v)) l)
(setq lst (cons (vlax-curve-getPointAtDist e d) lst))
)
)

(initget 0 "Crossing Within")
(setq *SWC:Opt*
(cond ((getkword (strcat "\nSpecify selection method witin curve [Crossing/Within] : "
)
)
)
(*SWC:Opt*)
)
)

(princ "\nSelect closed curves to select object(s) within: ")
(if (setq add (ssadd)
ss (ssget '((-4 . "<OR")
(0 . "CIRCLE,ELLIPSE,SPLINE")
(-4 . "")
(-4 . "OR>")
)
)
)
(progn (repeat (setq i (sslength ss))
(if (setq temp (ssget "_WP" (_pac (setq e (ssname ss (setq i (1- i)))))))
(repeat (setq i2 (sslength temp)) (ssadd (ssname temp (setq i2 (1- i2))) add))
)

(if (eq *SWC:Opt* "Crossing")
(progn (vla-getboundingbox (setq o (vlax-ename->vla-object e)) 'a 'b)
(setq pts (mapcar 'vlax-safearray->list (list a b)))
(if (setq tempC (ssget "_C"
(list (caar pts) (cadar pts) 0.)
(list (caadr pts) (cadadr pts) 0.)
)
)
(repeat (setq i3 (sslength tempC))
(if (vlax-invoke
o
'Intersectwith
(vlax-ename->vla-object (setq ec (ssname tempC (setq i3 (1- i3)))))
acExtendNone
)
(ssadd ec add)
)
)
)
)
)
)
(sssetfirst nil add)
(ssget "_I")
)
)
(princ)
)
(c:swc)

Recreate multiple hatch boundaries as polygons, each in the layer as his hach


;;;Recreate-Hatch-Boundaries.lsp written by Murray Clack, November 19, 2010
;;;Recreate multiple hatch boundaries as polygons, each in the layer as his hach.
(prompt "\nRecreate-Hatch-Boundaries.lsp loaded, Enter HB to execute")
(defun c:HB (/ OLDCE SSET CNT OBJ)
(setq OLDCE (getvar "cmdecho"))
(setvar "cmdecho" 0)
(princ "\nSelect Hatch Objects: ")
(setq SSET (ssget))
(setq CNT -1)
(while (setq OBJ (ssname SSET (setq CNT (1+ CNT))))
(setvar 'clayer (cdr (assoc 8 (entget OBJ))))
(command "-hatchedit" OBJ "b" "p" "n")
)
(setvar "cmdecho" OLDCE)
(princ)
)
(c:hb)

Convert ARCs,CIRCLEs,ELLIPSEs,LINEs,*POLYLINEs and SPLINEs to Revision Clouds with user Specified Revision Cloud Arc Length


;;; Convert ARCs,CIRCLEs,ELLIPSEs,LINEs,*POLYLINEs and SPLINEs to Revision Clouds with user Specified Revision Cloud Arc Length
;;; Created by Lee Mac (Lisp Grand Master and Wizard)
;;; Saved from: http://www.cadtutor.net/forum/showthread.php?94162-Multi-select-Pline-convert-to-revcloud
;;; Slightly modified by Igal Averbuh 2017 (Added option to Specify Revision Cloud Arc Length,
;;; to create solid hatch drawordered to back within revision cloud and to insert revision delta attributed block with revision number )

(defun c:DC ()
(setvar "attreq" 1)
(setq RevNo (getstring "\nRevision Layer Number: "))
(setq scl (getstring "\nRevision Delta Scale: "))

(command

"layer" "MAKE" (strcat "TPZ-REVISION-" RevNo) "COLOR" "1" "" ""

"INSERT" "DT" pause (strcat scl) (strcat scl) "0"

); command

(setvar "attreq" 0)

); defun

(defun c:mrc ( / c i s )

(setvar "osmode" 16384)
(command "-layer" "m" "TPZ-UPDATES" "C" "1" "" "")
(setvar 'dimscale
(cond ((getdist (strcat "\nSpecify Revision Cloud Arc Length : ")))
((getvar 'dimscale))
)
)
(if (setq s (ssget "_:L" '((0 . "ARC,CIRCLE,ELLIPSE,LINE,*POLYLINE,SPLINE"))))
(progn
(setq c (getvar 'cmdecho))
(setvar 'cmdecho 0)
(repeat (setq i (sslength s))
(command "_.revcloud" "_o" (ssname s (setq i (1- i))) "")

(setq hpn (getvar 'hpname))
(setvar 'hpname "SOLID")
(command "_.-BHATCH" "_S" "L" "" "")
(setvar 'hpname hpn)
(command "_.change" "L" "" "P" "C" "42" "")
(command "_.draworder" "L" "" "B")
(setvar "osmode" 167)
(princ)

)
(setvar 'cmdecho c)
)
)
(princ)

)

(defun c:AR ()
(c:mrc)
(c:dc)
)

BeekeeCZ Isolate Blocks by Name


;;; BeekeeCZ Isolate Blocks by Name
;;; Saved from: http://forums.autodesk.com/t5/visual-lisp-autolisp-and-general/isolate-block-without-turning-off/td-p/6487237
;;; Slightly modified by Igal Averbuh 2017 (added option to unisolate selected blocks)

; 1st select patern blocks (regular, not dynimacs blks) - it could be in model space or in layout.
; ... you can select all blocks within a boundary (boudaries)
; 2nd for defying the area you can use a classics selection window (inc. lasso) or select exists boundary object (closed *polyline, circle, ellipse)
; no boundaries, no limits.... it selects all filtred blocks in model space
; 1+2 and selects all block within model space.
; 3rd desired blocks are isolated

(vl-load-com)

(defun c:Ib ( / _pac ss new temp en i i2)

;; Based on routine written by Alan J. Thompson, 03.31.11
;; http://www.cadtutor.net/forum/showthread.php?57864-How-to-select-all-objects-enclosed-in-a-poly-line&p=392378&viewfull=1#post392378

(defun _pac (e / l v d lst)
(setq d (- (setq v (/ (setq l (vlax-curve-getDistAtParam e (vlax-curve-getEndParam e))) 100.))))
(while (< (setq d (+ d v)) l)
(setq lst (cons (vlax-curve-getPointAtDist e d) lst))))

(if (and (princ "\nSelect blocks for isolate: ")
(or (and (setq ss (cond ((ssget "_I" '((0 . "INSERT"))))
((ssget '((0 . "INSERT"))))))
(setq blocks "")
(repeat (setq i (sslength ss))
(setq blocks (strcat (cdr (assoc 2 (entget (ssname ss (setq i (1- i)))))) "," blocks)))
(setq blocks (vl-string-trim "," blocks))
(sssetfirst nil nil)
)
(setq blocks "*")
)
(or (if (/= "Model" (getvar 'CTAB)) (setvar 'CTAB "Model"))
T)
(setq new (ssadd))
(princ "\nSelect filtering area or press Enter to select all blocks within drawing: ")
(or (and (setq ss (ssget (list '(-4 . "<OR")
'(0 . "CIRCLE,ELLIPSE")

'(-4 . "")

'(-4 . "")

'(-4 . "OR>")
)))
(repeat (setq i (sslength ss))
(if (= "INSERT" (cdr (assoc 0 (entget (setq en (ssname ss (setq i (1- i))))))))
(ssadd en new)
(if (setq temp (ssget "_WP" (_pac en) (list '(0 . "INSERT") (cons 2 blocks))))
(repeat (setq i2 (sslength temp))
(ssadd (ssname temp (setq i2 (1- i2))) new)))))
)
(setq new (ssget "_X" (list '(0 . "INSERT")
(cons 2 blocks)
'(410 . "Model"))))
)
)
(command "_.ISOLATEOBJECTS" new ""))

(princ "\nType UB to UNISOLATE Selected Blocks")

(princ)
)
(c:ib)

(defun c:ub ( / )

(command "_.UNISOLATEOBJECTS" new "")
)

Dimension of curved and linear segments of polyline along arc and linear segments


;; DimPolySeqRedAbove.lsp [command names: DPI, DPO]
;; To dimension the lengths of all segments of a Polyline on the Inboard or Outboard
;; side, adding a red sequencing number above as prefix. For self-intersecting or open
;; Polyline without a clear "inside" and "outside," will determine a side -- if not as
;; desired, undo and run other command.
;; Dimensions along arc segments will be angular Dimensions, showing length of arc
;; as text override, not included angle native to angular Dimensions. They will not
;; update if Polyline is stretched, as Dimensions along line segments will.
;; Uses current Dimension and Units settings for linear Dimensions; angular for arc
;; segments currently set to round to nearest unit and add mm suffix [but see
;; instructions below to suit your standards].
;; Dimension line location distance from Polyline segment = 2 x dimension text height
;; for stacked fractions to clear [but see suggestion below re: stacked fractions, etc.].
;; Sequencing number + color & new-line are in text override; number is stored in non-
;; localized variable *DPseq. Remembers that, and continues sequence on subsequent
;; usage within same editing session of same drawing, whether using all DPI or all
;; DPO or a mixture of the two commands. To start at a different number, do this:
;; (setq *DPseq TheNextSequencingNumberYouWant)
;; Accepts LW and 2D "heavy" Polylines, but not 3D Polylines or meshes.
;; Kent Cooper, last edited 14 October 2016

(vl-load-com)

(defun DP (side / *error* clay cmde styht plsel pl cw inc pt1 pt2 pt3 pt4)

(defun *error* (errmsg)
(if (not (wcmatch errmsg "Function cancelled,quit / exit abort,console break"))
(princ (strcat "\nError: " errmsg))
); if
(setvar 'clayer clay)
(setvar 'osmode osm)

(setvar 'cmdecho cmde)
(princ)
); defun -- *error*

(setq clay (getvar 'clayer) osm (getvar 'osmode) cmde (getvar 'cmdecho))
(setvar 'cmdecho 0)
(setvar 'osmode 0)
(if (not *DPseq) (setq *DPseq 1))
(command

"_.layer" "_make" "0-ANNO-DIMS" "_color" 1 "" "" ;; vla-object (car plsel)))
(vla-offset pl styht); temporary
(setq cw (vla-object (entlast))) (vla-get-area pl)))
;; clockwise for closed or clearly inside/outside open; may not give
;; desired result for open without obvious inside/outside
(entdel (entlast))
(repeat (setq inc (fix (vlax-curve-getEndParam pl)))
(setq
pt1 (vlax-curve-getPointAtParam pl inc)
pt2 (vlax-curve-getPointAtParam pl (- inc 0.5)); segment midpoint
pt3 (vlax-curve-getPointAtParam pl (1- inc))
); setq
(if (equal (angle pt1 pt2) (angle pt2 pt3) 1e-8); line segment
(command ; then
"_.dimaligned" pt1 pt3
"_text" (strcat "")
;; see comments on ingredients under angular Dimension below
); [leaves at dimension line location prompt]
(command ; else [arc segment]
"_.dimangular" ""
(inters ; arc center
(setq pt4 (mapcar '/ (mapcar '+ pt1 pt2) '(2 2 2)))
(polar pt4 (+ (angle pt1 pt2) (/ pi 2)) 1)
(setq pt4 (mapcar '/ (mapcar '+ pt2 pt3) '(2 2 2)))
(polar pt4 (+ (angle pt2 pt3) (/ pi 2)) 1)
nil
); inters
pt1 pt3
"_text"
(strcat
""; new-line
(rtos (abs (- (vlax-curve-getDistAtParam pl inc) (vlax-curve-getDistAtParam pl (1- inc)))) 2 0); <--
;; EDIT mode/precision above to match linear Dimensions' text format
"" ; <--EDIT or omit as appropriate
); strcat
); command [leaves at dimension line location prompt]
); if
(command ; complete Dimension: dimension line location
(polar
pt2
(apply
(if (or (and cw (= side "in")) (and (not cw) (= side "out"))) '- '+)
(list
(angle '(0 0 0) (vlax-curve-getFirstDeriv pl (- inc 0.5)))
(/ pi 2)
); list
); apply
(* styht 2); <--EDIT as desired:
;; Depending on whether you use stacked fractions, fraction height scale, horizontal vs.
;; diagonal stacking, etc. experiment to find the ideal multiplier in place of the 2 above
); polar
); command
(setq
inc (1- inc)
*DPseq (1+ *DPseq)
); setq
); repeat
(setvar 'clayer clay)
(setvar 'osmode osm)

(setvar 'cmdecho cmde)
(princ)
); defun -- C:DP

(defun C:DPI () (DP "in")); = Dimension Polyline Inside
(defun C:DPO () (DP "out")); = Dimension Polyline Outside

(prompt "\nType DPI to sequence-Dimension Polyline on Inside, DPO on Outside.")

Draw Road Sections Labels


;;; Draw Road Sections Labels
;;; Created by Dave Corrall 12-Nov-2001
;;; Slightly modified by Igal Averbuh 2017

;degrees>radians
(defun dtr (a)
(* pi (/ a 180.0))
)
;radians>degrees
(defun rtd (a)
(* 180.0(/ a pi))
)

(defun intro ()
(setq dialog-state 999)
(setq dialog_pos (list -1 -1))
(setq dcl_id (load_dialog "intro.dcl"))
(princ "\nDialog Box:")
(while (< 2 dialog-state)
(new_dialog "intro" dcl_id "" dialog_pos)
(set_tile "lname" "Sections on Polyline")
(setq x (dimx_tile "DC")
y (dimy_tile "DC"))
(fill_image 0 0 x y -15)
(start_image "DC")
(slide_image 0 0 x y "dc_logo")
(end_image)
(action_tile "accept" "(done_dialog 1)")
(action_tile "cancel" "(quit_routine)")
(action_tile "about" "(setq userclick1 t)(open_about)")
(setq dialog-state (start_dialog))
(if (= dialog-state 1)
(princ)
; (princ "\nDialog Box: ")
)
)
(unload_dialog dcl_id)
; (princ "\nDialog Box: ")
)

; tell about routine

(defun open_about ()
; (done_dialog)
(startapp "notepad.exe" "chains.txt")
; (setq userclick1 nil)
)

(defun quit_routine ()
(setq qr "Q")
)

(defun chainage ()
(setq oreq(getvar"attreq")odia(getvar"attdia"))
(setq oldlayer(getvar "clayer"))
(setvar "attreq" 1)
(setvar "attdia" 0)
(setvar "osmode" 1024)
(command "ucs" "")
(setq r 0.0)
(setq seg 0.0)
(if (= (tblsearch "LAYER" "Sections") nil)
(command "layer" "m" "Sections" "c" "7" "" "")
(command "layer" "s" "Sections" "")
)
(setq step(getreal "\nSection Interval: ")
svprefix(getstring "\nPrefix (Enter for None): ")
scale(getdist "\nScale by two points on screen: ")
svval 0)
(setq nam (car (entsel "\nSelect LWPolyline for Section Labeling: ")))
(setq ent (entget nam))
(if (not (equal (cdr (assoc 0 ent)) "LWPOLYLINE"))
(prompt "\nEntity not a polyline...")
(progn
(setq nv (cdr(assoc 90 ent)))
(setq ent1 (member(assoc 10 ent)ent))
(setq ent2(cdr ent1))
(setq ent2(member(assoc 10 ent2)ent2))
(while (/= ent2 nil)
(if (/= ent2 nil)

(progn

; IF THE VERTEX PRECEDES A STRAIGHT LINE

(if (equal (cdr (assoc 42 ent1)) 0.0)
(progn
(setq v1(cdr(assoc 10 ent1))
v2(cdr(assoc 10 ent2))
a(angle v1 v2)
d(distance v1 v2)
p1(polar v1 a (- step r))
d1(distance p1 v2)
)
(if(< seg 1)
(progn
(setq value(strcat svprefix (rtos svval 2 0)))
(command "-insert" "sv" v1 scale scale (rtd a) value)
)
)
(if(<(+ d r) step)
(progn
(setq r (+ d r))
)
(progn
(setq num(1+(fix(/ d1 step))))
(setq cnt 0)
(repeat num
(progn
(setq pt(polar p1 a (* cnt step)))
(setq svval(+ svval step)
value(strcat svprefix (rtos svval 2 0)))
(command "-insert" "sv" pt scale scale (rtd a) value)
(setq cnt (1+ cnt))
)
)
(setq r(rem d1 step))
)
)
; set new values for variables
(setq ent1 ent2)
(setq ent2(cdr ent2))
(setq ent2(member(assoc 10 ent2)ent2))
(setq seg(1+ seg))
);end progn for straight section
;if the vertex preceds an arc
(progn
(setq v1(cdr(assoc 10 ent1))
v2(cdr(assoc 10 ent2))
bulge(cdr(assoc 42 ent1))
)
(setq a(angle v1 v2)
d(distance v1 v2)
radi(abs(/ d(* 2.0(sin(*(atan bulge) 2)))))
)
(setq hfd(/ d 2.0)
thet(atan(/(sqrt(-(* radi radi)(* hfd hfd)))hfd))
)
(if ( 180 deg
(if (< bulge 0) ; if clockwise
(setq dtoc (- a thet))
(setq dtoc (+ a thet))
)
(if ( bulge 0)
(setq ai (+ beg (* cnt astep))
ab(+ ai (dtr 90)))
(setq ai (- beg (* cnt astep))
ab(- ai (dtr 90)))
)
(setq pt (polar pc ai radi))
(setq svval(+ svval step)
value(strcat svprefix (rtos svval 2 0)))
(command "-insert" "sv" pt scale scale (rtd ab) value)
(setq cnt (1+ cnt))
)
)
(setq r(rem len1 step))
(if(equal r 0.0)(setq r step))
)
)
; set new values for variables
(setq ent1 ent2)
(setq ent2(cdr ent2))
(setq ent2(member(assoc 10 ent2)ent2))
);end progn for arc section
);end if check straight or arc
);end progn
);end if /= ent2 nil
);end while /= ent2 nil
)
)
;reset variables
(setvar "attreq" oreq)
(setvar "attdia" odia)
(command "layer" "s" oldlayer "")
(command "ucs" "p")
)
(defun thanku()
(setq dialog-state 999)
(setq dialog_pos (list -1 -1))
(setq dcl_id (load_dialog "thanks.dcl"))
(while (< 2 dialog-state)
(new_dialog "thanks" dcl_id "" dialog_pos)
(set_tile "lname" "Chainage Routine")
(setq x (dimx_tile "DC")
y (dimy_tile "DC"))
(fill_image 0 0 x y -15)
(start_image "DC")
(slide_image 10 10 x y "dc_logo")
(end_image)
(setq dialog-state (start_dialog))
(if (= dialog-state 1)
(princ)
)
)
(unload_dialog dcl_id)
(princ)
)

;command routine
(defun c:ch ()
(princ "Place SV Block to support path directory")
(intro)
(if(= qr "Q")
(progn
(setq qr nil)
(thanku)
)
(progn
(chainage)
(thanku)
)
)
)