;;;----------------------------------------------------------------------------------------------
;;;检查输入的原始参数表是否使用了组件的别名，如果使用了，便把别名改成组件全名。无论是否已使用组件的别名，都返回可供后续程序使用的参数表。
(defun listFormatInputList (listInput / listComponentAlias listFormatedInput listMemberOfInput
boolIsAlias intDefinedAliasNumber k strInputComponentName strAlias
)
;;;----------------------------------------------------------------------------------------------
;;;定义组件别名表，形式为 ( ( 组件别名 组件原名) )
(setq listComponentAlias '(("bt" "button")
("edit" "edit_box")
("edit12" "edit12_box")
("edit32" "edit32_box")
("listbox" "list_box")
("ComboBox" "popup_list")
("btRadio" "radio_button")
("tg" "toggle")
("btOK" "ok_only")
("btCancel" "cancel_button")
("btErrer" "errtile")
("btHelp" "help_button")
("btInfo" "info_button")
("btOC" "ok_cancel")
("btOCH" "ok_cancel_help")
("btOCHE" "ok_cancel_help_errtile")
("btOCHI" "ok_cancel_help_info")
("color17" "color_palette_1_7")
("color19" "color_palette_1_9")
("color09" "color_palette_0_9")
("color250255" "color_palette_250_255")
("stdColor" "std_rq_color")
)
)
;;;----------------------------------------------------------------------------------------------
(setq listFormatedInput nil)
(foreach listMemberOfInput listInput
(setq k 0
boolIsAlias "No"
)
(setq strInputComponentName (strcase (car listMemberOfInput) T))
(setq intDefinedAliasNumber (length listComponentAlias))
(while (and (< k intDefinedAliasNumber) (= boolIsAlias "No"))
(setq strAlias (strcase (car (nth k listComponentAlias)) T))
(if (= strInputComponentName strAlias)
(progn (setq boolIsAlias "Yes")
(setq listFormatedInput (append listFormatedInput
(list (cons (cadr (nth k listComponentAlias))
(cdr listMemberOfInput)
)
)
)
)
)
)
(setq k (1+ k))
)
(if (= boolIsAlias "No")
(setq listFormatedInput (append listFormatedInput
(list (cons (strcase (car listMemberOfInput) T)
(cdr listMemberOfInput)
)
)
)
)
)
)
listFormatedInput
)
;;;----------------------------------------------------------------------------------------------
;;;把输入的参数表转换为字符串表
(defun listInputToString (listInput / listMemberOfInput listCdrMemberOfInput
listMemberOfComponentParameters listComponentParameters listCadrMemberOfComponentParameters
listResult k j boolDefinementFound
strTmp test1 test2
)
;;;----------------------------------------------------------------------------------------------
;;;组件定义参数表，形式为 ( ( 组件名列表) ( 对应参数名列表) )
;;; 无属性控件，生成dcl文件时，在组件名后添加" ; “即可；如为“end”,在dcl文件里加上"}"字符即可
;;; 容器控件及带属性控件，需要在名前添加” : "，名后加 "{"
(setq listComponentParameters '((("容器控件" "dialog")
("label" "key" "value" "initial_focus"
"height" "width" "children_alignment" "children_fixed_height"
"children_fixed_width"
)
)
(("容器控件" "boxed_column" "boxed_row" "boxed_radio_column"
"boxed_radio_row" "column" "row" "radio_row" "radio_column"
"concatenation" "paragraph"
)
("label" "key" "is_enabled" "alignment"
"height" "width" "fixed_height" "fixed_width"
"children_alignment" "children_fixed_height" "children_fixed_width"
)
)
(("带属性控件" "button")
("label" "key" "action" "alignment" "height" "width" "horizontal_margin"
"vertical_margin" "fixed_height" "fixed_width" "is_cancel" "is_default" "is_enabled" "is_tab_stop"
"mnemonic"
)
)
(("带属性控件" "edit_box" "edit12_box" "edit32_box" "fcf_ebox" "fcf_ebox1")
("label" "key" "value" "action" "alignment" "height"
"width" "fixed_height" "fixed_width" "allow_accept" "edit_limit" "edit_width"
"is_enabled" "is_tab_stop" "mnemonic" "password_char"
)
)
(("带属性控件" "image" "image_block" "icon_image")
("key" "value" "action" "alignment" "height" "width"
"fixed_height" "fixed_width" "is_enabled" "is_tab_stop" "mnemonic" "aspect_ratio"
"color"
)
)
(("带属性控件" "image_button" "swatch" "fcf_ibut" "fcf_ibut1")
("key" "action" "alignment" "height" "width" "fixed_height"
"fixed_width" "is_enabled" "is_tab_stop" "mnemonic" "allow_accept" "aspect_ratio"
"color"
)
)
(("带属性控件" "list_box")
("label" "key" "value" "action" "alignment" "height"
"width" "fixed_height" "fixed_width" "allow_accept" "fixed_width_font"
"is_enabled" "is_tab_stop" "list" "mnemonic" "multiple_select"
"tabs" "tab_truncate"
)
)
(("带属性控件" "popup_list")
("label" "key" "value" "action" "alignment" "height"
"width" "fixed_height" "fixed_width" "edit_width" "fixed_width_font"
"is_enabled" "is_tab_stop" "list" "mnemonic" "tabs" "tab_truncate"
)
)
(("带属性控件" "radio_button")
("label" "key" "value" "action" "is_enabled" "is_tab_stop"
"mnemonic" "alignment" "height" "width" "fixed_height" "fixed_width"
)
)
(("带属性控件" "slider")
("label" "key" "value" "action" "alignment" "height"
"width" "fixed_height" "fixed_width" "big_increment" "layout" "max_value"
"min_value" "mnemonic" "small_increment"
)
)
(("带属性控件" "spacer")
("value" "height" "width" "fixed_height" "fixed_width")
)
(("带属性控件" "text" "text_part" "text_25")
("label" "key" "value" "alignment" "height" "width" "fixed_height" "fixed_width" "is_bold")
)
(("带属性控件" "toggle")
("label" "key" "value" "action" "alignment" "height" "width" "fixed_height" "fixed_width" "is_enabled"
"is_tab_stop")
)
(("无属性控件" "cancel_button" "errtile" "help_button"
"info_button" "ok_cancel" "ok_cancel_help" "ok_cancel_help_errtile"
"ok_cancel_help_info" "ok_only" "spacer" "spacer_0"
"spacer_1" "color_palette_1_7" "color_palette_1_9" "color_palette_0_9"
"color_palette_250_255" "std_rq_color"
)
)
(("无属性控件" "end")) ;以"end"作为单个组件定义的结束，生成dcl文件时，以“}“代替
)
)
;;;----------------------------------------------------------------------------------------------
(setq listResult nil)
(setvar "dimzin" 8)
(foreach listMemberOfInput listInput
(setq k 0
boolDefinementFound "NotYet"
)
(while (and (= boolDefinementFound "NotYet")
(< k (length listComponentParameters))
) ;未找到组件参数名列表且未搜索完组件预定义列表时循环
(setq listMemberOfComponentParameters (nth k listComponentParameters))
(if (and (member (car listMemberOfInput)
(car listMemberOfComponentParameters)
)
(if (= "spacer" (car listMemberOfInput))
(>= (length listMemberOfInput)
(length listMemberOfComponentParameters)
)
T
) ;因spacer既可为无属性控件也可为带属性控件，故特别处理
)
(progn (setq boolDefinementFound "Found"
listCdrMemberOfInput (cdr listMemberOfInput)
)
(cond ((or (= "容器控件" (car (car listMemberOfComponentParameters)))
(= "带属性控件" (car (car listMemberOfComponentParameters)))
)
listCdrMemberOfInput ;组件参数值有数据时
(setq listResult (append listResult
(list (strcat ":" (car listMemberOfInput) "{\n"))
)
)
(setq j 0
listCadrMemberOfComponentParameters (cadr listMemberOfComponentParameters)
)
(while (< j (length listCdrMemberOfInput))
(if (not (= "" (nth j listCdrMemberOfInput)))
(progn ;参数值非空时
(if (numberp (nth j listCdrMemberOfInput))
(setq strTMP (strcat (nth j listCadrMemberOfComponentParameters)
"="
(rtos (nth j listCdrMemberOfInput) 2 3)
";\n"
)
) ;参数为数值时
(setq strTMP (strcat (nth j listCadrMemberOfComponentParameters)
"=\""
(nth j listCdrMemberOfInput)
"\";\n"
)
) ;参数非数值时
)
(setq listResult (append listResult (list strTMP)))
)
)
(setq j (1+ j))
)
(if (= "带属性控件" (car (car listMemberOfComponentParameters)))
(setq listResult (append listResult (list "}\n")))
) ;带属性控件时，在字符串末尾加上组件结束标志 "}"
)
((= (car listMemberOfInput) "end")
(setq listResult (append listResult (list "}\n")))
)
(T ;(= "无属性控件" (car (car listMemberOfComponentParameters))) ,默认为无属性控件
(setq listResult (append listResult
(list (strcat (car listMemberOfInput) ";\n"))
)
)
)
)
)
(setq k (1+ k))
)
)
)
listResult
)
;;;----------------------------------------------------------------------------------------------
;;;生成并显示输入对话框
;;;调用形式 ( listGenerateDCL DCL文件名(无路径及后缀)
;;; 表( ( ( "组件名或别名") ( 参数值表 ) ) ...)
;;; 表( ( "组件编号" "组件初始值" ) ...) ;组件显示值初始化
;;; 表( ( "组件编号" "动作代码" ) ...) ;需设置动作的组件及对应的动作
;;; 表("组件编号" ...) ) ;用户点“确定”键时，需获取输入值的组件名
;;;注意，调用参数均为字符串形式
;;;返回值为表,形式为 ( 关闭对话框的整数代码 指定组件返回值列表)
(defun listGenerateDCL (strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions
listKeysToGetValue / listFormatedInput intDialogCloseType listKeysValue
listResult fStream strFileFullName objectFile fileStream
templist i dclid
)
;;;----------------------------------------------------------------------------------------------
;;;按 ( ( “组件名” “值" ) ) 表，设置各组件的值
(defun SetDCLValues (listKeysAndValues / listEachKeyAndValue)
(foreach listEachKeyAndValue listKeysAndValues
(set_tile (car listEachKeyAndValue)
(cadr listEachKeyAndValue)
)
)
)
;;;----------------------------------------------------------------------------------------------
;;;按 ( ( “组件名” “动作" ) ) 表，把组件与动作关联
(defun SetDCLActions (listKeysAndActions / listEachKeyAndAction)
(foreach listEachKeyAndAction listKeysAndActions
(action_tile (car listEachKeyAndAction)
(cadr listEachKeyAndAction)
)
)
)
;;;----------------------------------------------------------------------------------------------
;;;按 ( “组件名” ) 表，查询各组件值并返回值表
(defun listGetDCLValues (listKeys / listEachKey listValues)
(setq listValues nil)
(foreach listEachKey listKeys
(setq listValues (append listValues (list (get_tile listEachKey))))
)
listValues
)
;;;----------------------------------------------------------------------------------------------
(setq strFileFullName (vl-filename-mktemp (strcat strDCLFileName ".dcl")))
(setq objectFile (open strFileFullName "w"))
(setq listFormatedInput (listFormatInputList listInputDefinements))
(setq fileStream (append (list strDCLFileName)
(listInputToString listFormatedInput)
)
)
(foreach fStream fileStream (princ fStream objectFile))
(close objectFile)
;;以上生成dcl文件,以下调用DCL，设置组件值、关联动作，获取返回值
(setq listResult nil)
(setq dclid (load_dialog strFileFullName))
(if (not (new_dialog strDCLFileName dclid ""))
(progn (alert "对话框加载失败!") (exit))
)
(if listKeysAndValues
(SetDCLValues listKeysAndValues)
)
(if listKeysAndActions
(SetDCLActions listKeysAndActions)
)
(if listKeysToGetValue
(action_tile "accept" "(setq listKeysValue (listGetDCLValues listKeysToGetValue)) (done_dialog 1)" )
)
(setq intDialogCloseType (start_dialog))
(unload_dialog dclid)
(vl-file-delete strFileFullName)
(setq listResult (append (list intDialogCloseType) listKeysValue))
listResult
)
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;----------------------------------------------------------------------------------------------
;;;;funlib.lsp
;;; -------------------------------------------------------------------------
;;;计算以当前设置书写的文本占用长度
;;;调用参数形式 ( 字符串 )
(defun strLength (str / sLength x1 x2 lst)
(setq lst (textbox (list (cons 1 str))))
(setq x1 (car (nth 0 lst))
x2 (car (nth 1 lst))
)
(setq sLength (abs (- x2 x1)))
sLength
)
;;; -------------------------------------------------------------------------
;;;以当前设置初始化文本高、宽
(defun initText (/ pt str eTextN)
(setq pt (list 0 0))
(setq str "初始化")
(command "text" pt #ZiGao# 0 str)
(setq eTextN (entlast))
(entdel eTextN)
)
;;; -------------------------------------------------------------------------
;;; 返回polyline的点表
;;;调用参数形式 ( 多义线图元名 )
(defun getplpts (pl / mark pts ver1 i ee pt)
(if (= "POLYLINE" (cdr (assoc 0 (entget pl))))
(progn ; read points of ployline
(setq mark "VERTEX"
i 0
ver1 (entnext pl)
)
(while (= "VERTEX" mark)
(setq pts (append pts (list (cdr (assoc 10 (entget ver1))))))
(setq ver1 (entnext ver1)
i (1+ i)
)
(setq mark (cdr (assoc 0 (entget ver1))))
)
)
(progn ; read points of lwployline
(setq ee (entget pl))
(foreach pt ee
(if (= 10 (car pt))
(setq
pts (append
pts
(list (append (cdr pt) (list (cdr (assoc 38 ee)))))
)
)
)
)
)
)
pts
)
;;; -------------------------------------------------------------------------
;;;实数转换为桩号，并返回转换后的结果
;;;调用参数形式 ( 里程的数值 里程的前缀 )
(defun rtoZhuanHao (rZhuanHao QianZhui / sZhuanHao QianMi)
; rZhuanHao为需要转换为桩号的实数
; bzZhuanHao为桩号的前缀
; SZhuanHao为转换后的桩号字串
(if (< rZhuanHao 0)
(progn
(setq QianZhui (strcat "-" QianZhui))
(setq rZhuanHao (abs rZhuanHao))
)
)
(setq rZhuanHao (fixreal rZhuanHao 2))
(setq QianMi (fix (/ rZhuanHao 1000)))
(setq rZhuanHao (- rZhuanHao (* QianMi 1000)))
(setq sZhuanHao (strcat QianZhui (rtos QianMi 2 0) "+"))
(if (< rZhuanHao 10)
(setq sZhuanHao (strcat sZhuanHao "00"))
(if (< rZhuanHao 100)
(setq sZhuanHao (strcat sZhuanHao "0"))
)
) ;不足位数桩号在前缀补位
(setq sZhuanHao (strcat sZhuanHao (rtos rZhuanHao 2 2)))
sZhuanHao
)
;;; -------------------------------------------------------------------------
;;;将ag调整到-pi/2~pi/2，并返回调整后的结果
(defun AngInHalfPi (ag)
(setq ag (if (and (> ag (/ pi 2)) (< ag (* pi 1.5)))
(- ag pi)
ag
)
)
ag
)
;;; -------------------------------------------------------------------------
;;;将ag调整到0~pi，并返回调整后的结果
(defun AngInPi (ag / twoPi)
(setq twoPi (* 2 pi))
(if (< ag 0)
(while (< ag 0)
(setq ag (+ ag twoPi))
)
(while (>= ag twoPi)
(setq ag (- ag twoPi))
)
)
ag
)
;;; -------------------------------------------------------------------------
;;; 读取纬地道路软件格式的纵断面文件，并返回数据表，失败时返回nil
;|
(defun GetDateFromZDMFile
(/ FileName File1 LST STR zdmList nt n ZH GaoCheng R ch zdmDateFormat)
(setq zdmList nil)
(if (setq FileName (getfiled "选择纬地纵断面文件" "" "zdm" 4))
(progn
;;读模式打开纵断面数据文件
(setq File1 (open FileName "r"))
;;逐行读入
(setq n 1
zdmDateFormat
"正确格式"
)
;;;n用于记录当前行序号为第一行或非第一行
(while (and (setq STR (read-line File1))
(= zdmDateFormat "正确格式")
)
(if (= n 1)
(progn
(setq nt (read str))
(if (numberp nt)
(setq zdmList (list (list nt)))
(progn
(setq zdmList nil)
(setq zdmDateFormat "错误格式")
(princ (strcat "\n纵断面数据文件第1行数格式有误:不是整数!"))
)
)
)
(progn
(setq ZH nil
GaoCheng nil
R nil
)
(setq ZH (read str))
(while (and (/= (setq ch (substr str 1 1)) " ")
(>= (strlen str) 1)
)
(setq str (substr str 2))
)
(while (and (= (setq ch (substr str 1 1)) " ")
(>= (strlen str) 1)
)
(setq str (substr str 2))
)
(setq GaoCheng (read str))
;;;取得高程
(while (and (/= (setq ch (substr str 1 1)) " ")
(>= (strlen str) 1)
)
(setq str (substr str 2))
)
(while (and (= (setq ch (substr str 1 1)) " ")
(>= (strlen str) 1)
)
(setq str (substr str 2))
)
(setq R (read str))
;;;取得高程
(if (and (numberp ZH)
(numberp GaoCheng)
(numberp R)
)
(setq zdmList (append zdmList (list (list ZH GaoCheng R))))
(progn
(setq zdmList nil)
(setq zdmDateFormat "错误格式")
(princ
(strcat "\n纵断面数据文件第" (rtos n 2 0) "行数据格式有误!")
)
)
)
)
)
(setq n (1+ n))
)
;;关闭文件
(close File1)
)
)
(if (/= nt (- n 2))
(progn
(setq zdmList nil)
(princ
"\n纵断面数据文件格式有误:数据文件中指定的变坡点总数与实际的变坡点总数不符!"
)
)
)
zdmList
) ;_ 结束defun
|;
(defun GetDateFromZDMFile (/ strFileName objectFile LineN listN zdmList )
(setq zdmList nil)
(if (setq strFileName (getfiled "选择纬地道路软件或鸿业市政道路软件的纵断面设计数据文件(*.zdm或*.bgs)" "" "" 4))
(progn
;;读模式打开纵断面数据文件
(setq objectFile (open strFileName "r"))
;;逐行读入
(while (setq LineN (read-line objectFile))
(setq listN (read LineN)) ;单行字符串以"("开始，以")"结尾时，如鸿业市政道路软件数据文件格式
(if (not (listp listN))
(setq listN (read (strcat "(" LineN ")" ))) ;单行字符串无小括号时，如纬地道路软件数据文件格式
)
(if (and (> (length listN) 2)
(numberp (car listN))
(numberp (cadr listN))
(numberp (caddr listN))
)
(setq zdmList (append zdmList (list listN)))
)
)
(close objectFile)
(if (> (length zdmList) 1)
(setq zdmList (append (list (list (length zdmList))) zdmList))
(progn
(setq zdmList nil)
(princ "\n纵断面数据文件格式有误,有效变坡点可能不足两个!" )
)
)
)
)
zdmList
)
;;;------------------------------------------------------------------------
;;;计算指定里程点的高程，成功则返回计算结果，否则返回提示出错原因的字符串
;;;调用参数形式 ( 纵断面设计数据表( 由GetDateFromZDMFile计算得到 ) 需查询高程的里程 )
(defun ZDMBiaoGao (zdmList ZhuanHao / zhQ bgQ zhA bgA rA TA zhTA TB zhTB zhB bgB
rB zhH bgH iQA iAB iBH diA diB
;;;zh开头表示桩号;bg开头表示标高;r开头表示竖曲线;
;;;A,B当前里程所在区间前后点
;;;Q,A点之前变坡点;Ta,A处竖曲线,A点后切线点;TB,B处竖曲线,B点前切线点;H,B点后变坡点
;;;iQA iAB iB di,分别为前坡段坡度,AB坡度,后坡段坡度,坡度差
;;;T表示切点
h0
;;;未计竖曲线时高程
hc
;;;竖曲线高程修正高程
h
;;;设计高程
AoTuR
;;;竖曲线凹凸,ao,凹;tu,凸
n nt x rStr OK RorS
)
(setq nt (car (nth 0 zdmList)))
(setq RorS "str")
(if (>= nt 2)
(progn
(setq zhA (car (nth 1 zdmList)))
(setq zhB (car (nth nt zdmList)))
(cond
((< ZhuanHao zhA) (setq rStr "桩号过小"))
((> ZhuanHao zhB) (setq rStr "桩号过大"))
((<= zhA ZhuanHao zhB)
(progn
(setq n 2)
(setq OK 0)
(while (= OK 0)
(setq zhB (car (nth n zdmList)))
(if (<= ZhuanHao zhB)
(progn
;;;开始数据准备
(setq bgA (cadr (nth (1- n) zdmList)))
(setq bgB (cadr (nth n zdmList)))
(setq iAB (/ (- bgB bgA) (- zhB zhA)))
(if (= n 2)
(progn
(setq diA 0)
(setq rA 1)
(if (> nt 2)
;;;纵断面不只有一个坡段时
(progn
(setq rB (caddr (nth 2 zdmList)))
(setq zhH (car (nth 3 zdmList)))
(setq bgH (cadr (nth 3 zdmList)))
(setq iBH (/ (- bgH bgB) (- zhH zhB)))
(setq diB (- iBH iAB))
)
)
)
)
;;;点在第一段纵坡上时
(if (= n nt)
(progn
(setq diB 0)
(setq rB 1)
(if (> nt 2)
;;;纵断面不只有一个坡段时
(progn
(setq rA (caddr (nth (1- n) zdmList)))
(setq zhQ (car (nth (- n 2) zdmList)))
(setq bgQ (cadr (nth (- n 2) zdmList)))
(setq iQA (/ (- bgA bgQ) (- zhA zhQ)))
(setq diA (- iAB iQA))
)
)
)
)
;;;点在最后一段纵坡上时
(if (and (/= n 2) (/= n nt))
(progn
(setq rA (caddr (nth (1- n) zdmList)))
(setq zhQ (car (nth (- n 2) zdmList)))
(setq bgQ (cadr (nth (- n 2) zdmList)))
(setq rB (caddr (nth n zdmList)))
(setq zhH (car (nth (1+ n) zdmList)))
(setq bgH (cadr (nth (1+ n) zdmList)))
(setq iQA (/ (- bgA bgQ) (- zhA zhQ)))
(setq iBH (/ (- bgH bgB) (- zhH zhB)))
(setq diA (- iAB iQA))
(setq diB (- iBH iAB))
)
)
;;;点不在第一段也不在最后一段纵坡上时
(setq TA (abs (* diA (* 0.5 rA))))
(setq TB (abs (* diB (* 0.5 rB))))
(setq zhTA (+ zhA TA))
(setq zhTB (- zhB TB))
;;;结束数据准备
(cond
((< ZhuanHao zhTA)
(progn
(setq x (- zhTA ZhuanHao))
(setq hc (* 0.5 (/ (* x x) rA)))
(if (< diA 0)
(setq AoTuR "tu")
(setq AoTuR "ao")
)
)
)
;;;里程点在A点竖曲线上时
((<= zhTA ZhuanHao zhTB)
(progn
(setq hc 0)
;;竖曲线修正值为0
(setq AoTuR "ao")
;;;里程点不在竖曲线上,采用凹曲线的计算公式
)
)
;;;里程点不在竖曲线上时
((> ZhuanHao zhTB)
(progn
(setq x (- ZhuanHao zhTB))
(setq hc (* 0.5 (/ (* x x) rB)))
(if (< diB 0)
(setq AoTuR "tu")
(setq AoTuR "ao")
)
)
)
;;;里程点在B点竖曲线上时
)
;;;计算竖曲线高程修正值，并判断曲线的凹凸
(setq h (+ bgA (* iAB (- ZhuanHao zhA))))
;;;计算未含竖曲线修正值时的设计高程
(if (= AoTuR "ao")
(setq h (+ h hc))
(setq h (- h hc))
)
;;;计算最终设计高程
(setq OK 1)
(setq RorS "real")
)
(progn
(setq zhA zhB)
(setq n (1+ n))
)
)
)
)
)
)
)
(setq rStr "数据文件有误")
)
(if (= RorS "real")
h
rStr
)
;;;输出返回值
) ;_ 结束defun
;;;------------------------------------------------------------------------
;;;判断点位位曲线的左侧、右侧、还是在曲线上
;;;返回结果为字符串，有三种："右侧" "左侧" "在中线上"
;;;调用参数形式 ( 曲线图元名 需判断左右的点 点与曲线的垂足 垂足到曲线起点的曲线长度 里程增加方向 )
(defun strZhuoYou (oblname PJ PjP LPjP FS / ZhuoYou PP agPJ agPP agD)
(if (/= (distance PJ PjP) 0)
(progn
(if (= FS "同向")
(setq PP (vlax-curve-getPointAtDist oblname (- LPjP 0.001)))
(setq PP (vlax-curve-getPointAtDist oblname (+ LPjP 0.001)))
)
;;;取得里程比井里程小0.001的点坐标
(setq agPP (angle PjP PP))
;;
jP->P方位角(0~2 Pi)
(setq agPJ (angle PjP PJ))
;;jP->J方位角(0~2 Pi)
(setq agD (- agPJ agPP))
;;;方位角差
(if (or (< (abs (- agD (* pi 0.5))) 0.5)
(< (abs (+ agD (* pi 1.5))) 0.5)
)
;;;方位角差为pi/2或1.5pi,最大误差为0.5
(setq ZhuoYou "右侧")
(setq ZhuoYou "左侧")
)
;;;点位于道路左侧或右侧
)
(setq ZhuoYou "在中线上")
)
ZhuoYou
)
;;;------------------------------------------------------------------------
;;;回四舍五入函数，返四舍五入后的实数
;;;调用参数形式 ( 数值 小数位数 )
(defun fixReal (数值 小数位数 / N2 n10 NReturn)
(setq n10 (expt 10 小数位数))
(setq N2 (fix (* 数值 2 n10)))
(setq NReturn (+ (/ N2 2) (rem N2 2)))
(setq NReturn (/ (float NReturn) (float N10)))
NReturn
)
;;; -------------------------------------------------------------------------
;;; 选择圆，允许按直径条件过滤，并返回选择集表
;;;调用参数形式 ( “提示需要进行的操作”+“圆及其修饰” 的文本 )
(defun SelectCircles (OperationStr / obcName nob obc obcK i KeyW KeyR cR cList nList obType)
(if (ssgetfirst)
(setq obc (ssget "_P" '((0 . "circle"))))
) ;有预选择时，从预选择集中找出被选择的圆选择集
(if (not obc)
(progn
(princ (strcat "\n选择需要" OperationStr ":"))
(setq obc (ssget '((0 . "circle")))) ; 创建选择集 obc
) ;无预选择或预选择中无圆图元时
)
(if obc
(progn
(setq nob (sslength obc))
(initget "Y N R _Yes No ReSelect")
(setq KeyW
(getkword
(strcat "\n是否选择了不需要"
OperationStr
"[是(Y)/否(N)/重新选择(R)]<N>:"
)
)
)
(cond
((= KeyW "Yes")
(initget 6)
(setq
KeyR (getreal
(strcat
"\n指定需要"
OperationStr
"的直径(右键或回车表示所有选择的圆均需要进行操作):"
)
)
)
(if (numberp KeyR)
(progn
(setq i 0
cList nil
)
(repeat nob
(setq obcK (ssname obc i))
(setq cR (cdr (assoc 40 (entget obcK))))
(if (/= cR (/ KeyR 2.0))
(setq cList (append cList (list obcK)))
)
(setq i (1+ i))
) ;计算需要从选择集中去除的图元的名称表
(setq i 0)
(repeat (length cList)
(ssdel (nth i cList) obc)
(setq i (1+ i))
)
;从选择集中去除不符合条件的图元
)
)
)
((= KeyW "ReSelect")
(princ (strcat "\n重新选择需要" OperationStr ":"))
(setq obc (ssget '((0 . "circle")))) ; 创建选择集 obc
)
(T nil)
)
)
)
obc
)
;;; -------------------------------------------------------------------------
;;;根据里程计算井点的坐标，成功则返回表 （ 坐标，点所在里程处中线在里程增加方向的切线角） ， 否则返回nil
;;;为减少程序的计算量，调用参数多设置了两个
;;;调用参数形式 ( 中线对象 中线长度 起点里程 里程方向 终点里程 里程 左右 距离 )
(defun getPointByLiChengZhuoYouJuLi (中线对象 中线长度 起点里程 里程方向 终点里程 里程 左右 距离 / ag Dst obPoint lst)
(setq obPoint nil
ag 0
lst nil
)
(if (or (and (= 里程方向 "同向") (<= 起点里程 里程 终点里程))
(and (/= 里程方向 "同向") (>= 起点里程 里程 终点里程))
)
(progn
(setq Dst (abs (- 里程 起点里程)))
(setq ZhongDian (vlax-curve-getPointAtDist 中线对象 Dst))
;;根据里程计算中点坐标
(if (= 距离 0) ;判断井是否在路中线上
(setq obPoint ZhongDian)
(progn
(setq ag (AngleQieXiang 中线对象 ZhongDian))
;;计算切线角
(if (or (and (= 里程方向 "同向") (= 左右 "左侧"))
(and (/= 里程方向 "同向") (/= 左右 "左侧"))
)
(setq obPoint (polar ZhongDian (+ ag (* pi 0.5)) 距离))
(setq obPoint (polar ZhongDian (+ ag (* pi 1.5)) 距离))
)
) ;计算要求点不在路中线上时的坐标
)
(if (and (/= 距离 0)
(/= 里程方向 "同向")
)
(setq ag (+ ag pi))
) ;点所在里程处中线在里程增加方向的切线角
(setq lst (list obPoint ag)) ;计算成功时，生成结果表
)
) ;里程有效时，计算坐标及切线角度
lst ;返回结果表
)
;;; -------------------------------------------------------------------------
;;;如果成功，返回表： ( 中线 中线起点里程 里程增加与曲线正向的关系 终点里程 中线长 ) ;否则返回nil
;;;调用形式( GetZhongXiang nil或任意值) 如果参数不为nil时，将强制重新设置路中线扩展数据
;;;生成的扩展数据格式为
"PS_DLZX" (1040 起点里程) (1040 终点里程) ) 注：此处的起终点为cad线图的起终点，非道路真实起终点
(defun GetZhongXiang (strResetXData / intSelectedSetNumber ssSelected
strZhongXiangEntityName listZhongXiangXData LZhongXiang
QiDianLiCheng ZhongDianLiCheng LiChengFangXiang strLiChengQianZhui listResult keyW
)
;;;-------------------------------------------------------------
;;;获取中线的xdata数据，并计算道路资料
(defun GetFromXData (/ keyword tmpList )
(setq strLiChengQianZhui (cdr (cadr listZhongXiangXData)))
(setq tmpList (caddr listZhongXiangXData))
(setq QiDianLiCheng (cadr tmpList))
(setq ZhongDianLiCheng (caddr tmpList))
(if (<= QiDianLiCheng ZhongDianLiCheng)
(setq LiChengFangXiang "同向")
(setq LiChengFangXiang "反向")
)
(setq LZhongXiang
(vlax-curve-getDistAtParam
strZhongXiangEntityName
(- (vlax-curve-getEndParam strZhongXiangEntityName)
(vlax-curve-getStartParam strZhongXiangEntityName)
)
)
) ;中线长度
(if (< -1
(- (abs (- ZhongDianLiCheng QiDianLiCheng)) LZhongXiang)
1
) ;判断定义路中线后，中线对象是否被改变
(if (<= QiDianLiCheng ZhongDianLiCheng) ;中线对象未被修改或仅被微调时
(setq ZhongDianLiCheng (+ QiDianLiCheng LZhongXiang))
(setq QiDianLiCheng (+ ZhongDianLiCheng LZhongXiang))
) ;根据实际的道路起点里程及 道路长度重新计算路终里程，以免若路中线被微调，所计得到的设置不正确
(progn ;中线对象已被修改时
(initget "A R _AutoSet Reset")
(setq keyword (getkword
"路中线在定义后已被改变[按原定义的起点及方向自动调整(A)/重新定义(R)]<A>:"
)
)
(if (= keyword "Reset")
(InterSet)
(if (<= QiDianLiCheng ZhongDianLiCheng)
(setq ZhongDianLiCheng (+ QiDianLiCheng LZhongXiang))
(setq QiDianLiCheng (+ ZhongDianLiCheng LZhongXiang))
) ;根据实际的道路起点里程及 道路长度重新计算路终里程
)
)
)
)
;;;-------------------------------------------------------------
;;;以交互形式设置中线信息
(defun InterSet (/ ckPointA KCKPA ckPointB kw zhFangShang LCKPA LCKPB LinShiPoint)
;;zhFangShang为用于判断里程增加方向，为正时，曲线开始点为里程起点，反之为终点
(setvar "osmode" 431)
(setq ckPointA nil
ckPointB nil
LinShiPoint nil
)
(while (not ckPointA)
(setq ckPointA (getpoint "\n指定中线上一点:"))
(setq LinShiPoint (vlax-curve-getClosestPointTo strZhongXiangEntityName ckPointA T ) )
(if (<= (distance ckPointA LinShiPoint) 0.5) ;两点的距离在0~0.5之间时
(setq ckPointA LinShiPoint)
(progn
(setq ckPointA nil)
(princ "\n所指定的点不在指定的道路中心线上,请重新指定!")
)
)
)
(if (not (setq KCKPA (getreal "\n输入参考点的里程数值<0>:")))
(setq KCKPA 0)
)
(while (not ckPointB)
(setq ckPointB (getpoint "\n指定路中线上的另一点:"))
(setq LinShiPoint (vlax-curve-getClosestPointTo strZhongXiangEntityName ckPointB T ) )
(if (<= (distance ckPointB LinShiPoint) 5.0) ;两点的距离在0~5.0之间时
(setq ckPointB LinShiPoint)
(progn
(setq ckPointB nil)
(princ "\n所指定的点不在指定的道路中心线上,请重新指定!")
)
)
(if (and ckPointB
(<= (distance ckPointB ckPointA) 0.1) ;如果两点的距离在0~0.1之间时，两点看做为同一点
)
(progn
(setq ckPointB nil)
(princ
"\n第二次指定的点与第一次指定的点相同,请重新指定与第一点不同的点!"
)
)
)
)
(setvar "osmode" 0)
(initget "A S _Add Sub")
(setq kw (getkword
"\n第二点里程相对第一点的里程是[增加(A)/减少(S)]<A>:"
)
)
(if (= kw "Sub")
(setq zhFangShang -1)
(setq zhFangShang 1)
) ; 默认相对里程为增加
(setq LCKPA (vlax-curve-getDistAtPoint strZhongXiangEntityName ckPointA)) ; 第一点到曲线起点的长度
(setq LCKPB (vlax-curve-getDistAtPoint strZhongXiangEntityName ckPointB)) ; 第二点到曲线起点的长度
(setq LZhongXiang
(vlax-curve-getDistAtParam
strZhongXiangEntityName
(- (vlax-curve-getEndParam strZhongXiangEntityName)
(vlax-curve-getStartParam strZhongXiangEntityName)
)
)
) ;中线长度
(if (> (* zhFangShang (- LCKPB LCKPA)) 0)
(progn
(setq QiDianLiCheng (- KCKPA LCKPA)) ; 中线起点(曲线起点)里程
(setq ZhongDianLiCheng (+ QiDianLiCheng LZhongXiang))
;;终点里程
(setq LiChengFangXiang "同向") ; 里程增加方向与中线起点到终点方向相同
)
(progn
(setq QiDianLiCheng (+ KCKPA LCKPA)) ; 中线起点(曲线起点)里程
(setq ZhongDianLiCheng (- QiDianLiCheng LZhongXiang)) ;终点里程
(setq LiChengFangXiang "反向") ; 里程增加方向与中线起点到终点方向不同
)
) ;判断里程方向与曲线方向的关系，并确定曲线起终点的里程
(if (= "" (setq strLiChengQianZhui (getstring "\n输入里程的前缀<K>:")))
(setq strLiChengQianZhui "K")
)
(SetXdata strZhongXiangEntityName
(list "PS_DLZX"
(cons 1000 strLiChengQianZhui)
(list 1010 QiDianLiCheng ZhongDianLiCheng 0)
)
)
;;把起点里程及 终点里程定义添加到中线对象的标记为"PS_DLZX" 的扩展数据中
)
;;;-------------------------------------------------------------
(setq listResult nil)
(vl-cmdf "ucs" "w")
(setq intSelectedSetNumber 2)
(while (> intSelectedSetNumber 1)
(princ "\n选择路中线(只能选择一条线):")
(setq ssSelected (ssget '((0 . "*line,arc")))) ; 创建选择集 ssSelected
(if ssSelected
(setq intSelectedSetNumber (sslength ssSelected))
(setq intSelectedSetNumber 2)
)
)
(setq strZhongXiangEntityName (ssname ssSelected 0)) ; oblname，取得中线对象名
(setq listZhongXiangXData (cadr (assoc -3 (entget strZhongXiangEntityName '("PS_DLZX")) )))
(if listZhongXiangXData
(if (= strResetXData "是")
(progn
(initget "S R _Set Remain")
(setq keyW (getkword "该路中线已经被定义![重新定义(S)/保留原定义(R)]<R>:" ) )
(if (= keyW "Set")
(InterSet) ;如果指定重新设置，设置路中线信息
)
)
(GetFromXData) ;不指定重新设置时，从扩展数据计算路中线信息
) ;存在已定义的路中线扩展数据时
(InterSet) ;未设置有扩展的路中线数据时，重头设置路中线信息
)
(setq listResult (list strZhongXiangEntityName QiDianLiCheng LiChengFangXiang ZhongDianLiCheng LZhongXiang strLiChengQianZhui) )
listResult
)
;;;-------------------------------------------------------------
;| (SetXdata strEntityName listApp) = entmod方式,给实体添加或更新或删除扩展数据.-----梁雄啸.2004.10.1
参数: strEntityName = 实体名.
listApp = '("注册名" 项1 项2 ...) ;用于添加或更新. 如(list "test" '(1070 . 1234)'(1003 . "0"))
'("注册名") ; 用于删除相关注册项的xdata.
nil ; 用于删除实体全部的xdata.
说明: 支持所有实体.非图形实体不支持viewport(必须用 vlax-ldata-put.或setxdata方法).
参考 entmod 帮助.
相关: 参照 ()函数=vla方式,支持所有的扩展数据修改.
实例: 1.增加(如已经有,则为更新)指定注册名的xdata:
(SetXdata (car(entsel)) (list "test" (cons 1070 1234)))
2.删除指定注册名的xdata:
(SetXdata (car(entsel)) '("test"))
3.删除所有的扩展数据:
(SetXdata (setq strEntityName(car(entsel))) nil)
|;
(defun SetXdata (strEntityName listApp / listApps)
(if listApp
(regapp (car listApp))
)
;;无论是否已经有,均注册.有重复的话无不利影响.
(if listApp
(entmod (list (cons -1 strEntityName) (list -3 listApp)))
;;新建,更新,或删除指定app,{用 '("注册名") }.
(progn ;;删除所有的扩展数据.
(setq listApps (mapcar 'car (cdr (assoc -3 (entget strEntityName '("*"))))))
(entmod (list (cons -1 strEntityName)
(cons -3 (mapcar 'list listApps))
)
)
)
)
)
;;;-------------------------------------------------------------
;;;计算曲线上一点处的正向切线角0～2 pi
;;;调用形式 （曲线对象名 曲线上一点的坐标） ：未处理坐标不在曲线上的情况
(defun AngleQieXiang (曲线 pt / para Pt1 ag)
(setq para (vlax-curve-getParamAtPoint 曲线 pt))
(setq Pt1 (vlax-curve-getFirstDeriv 曲线 para))
(setq ag (angle '(0 0) Pt1))
;;计算切线角
ag
)
;;;-------------------------------------------------------------
;;;在当前图层、当前空间画直线
;;;调用形式 ( AddLine 起点坐标 终点坐标 )，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddLine (listStartPoint listEndPoint)
(entmake (list '(0 . "LINE")
(cons 10 listStartPoint)
(cons 11 listEndPoint)
)
)
)
;;;-------------------------------------------------------------
;;;计算从角1到角2逆时针的角度差
;;;返回0~2 pi的正值
(defun AngleDelta ( fStartAngle fTargetAngle / fDelta)
(setq fDelta (- fTargetAngle fStartAngle ))
(if (< fDelta 0)
(setq fDelta (+ fDelta (* 2 pi)))
)
fDelta
)
;;;-------------------------------------------------------------
;;;在当前图层、当前空间画圆
;;;调用形式 ( AddCircle 圆心坐标 半径 )，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddCircle (listCenterPoint floatRadius)
(entmake (list '(0 . "CIRCLE")
(cons 10 listCenterPoint)
(cons 40 floatRadius)
)
)
)
;;;------------------------------------------------------------------------
;;;在当前图层、当前空间、按文本居中方式，写单行文本
;;;调用形式 ( AddText_AlignmentMiddle 插入点坐标 字高 文本旋转角度(rad) 文本内容 宽高比例 字体样式名)，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddText_AlignmentMiddle (listInsertPoint floatTextHigh floatRotateAngle strText floatScaleFactor strStyleName)
(entmake (list '(0 . "TEXT")
'(10 0 0 0)
(cons 11 listInsertPoint)
(cons 40 floatTextHigh)
(cons 1 strText)
(cons 50 floatRotateAngle)
(cons 41 floatScaleFactor)
(cons 7 strStyleName)
'(72 . 1)
'(100 . "AcDbText")
)
)
)
;;;------------------------------------------------------------------------
;;;在当前图层、当前空间、按文本左对齐方式，写单行文本
;;;调用形式 ( AddText_AlignmentLeft 插入点坐标 字高 文本旋转角度(rad) 文本内容 宽高比例 字体样式名)，如果成功，返回定义数据的图元表，否则返回 nil。
(defun AddText_AlignmentLeft (listInsertPoint floatTextHigh floatRotateAngle strText floatScaleFactor strStyleName)
(entmake (list '(0 . "TEXT")
(cons 10 listInsertPoint)
(cons 40 floatTextHigh)
(cons 1 strText)
(cons 50 floatRotateAngle)
(cons 41 floatScaleFactor)
(cons 7 strStyleName)
'(100 . "AcDbText")
)
)
)
;;;------------------------------------------------------------------------
;;;在当前图层、当前空间插入块
;;;调用形式 ( InsertBlock 块名 插入点 旋转角度 )
;;;成功时，返回dxf组码，否则返回nil
(defun InsertBlock ( strBlockName listInsertPoint floatRotateAngle )
(entmake (list '(0 . "INSERT")
'(100 . "AcDbEntity")
'(100 . "AcDbBlockReference")
(cons 2 strBlockName)
(cons 10 listInsertPoint)
(cons 50 floatRotateAngle)))
)
;;;-------------------------------------------------------------
;;;标记undo编组开始点
(defun BeginUndoGroup()
(command "undo" "be")
)
;;; -------------------------------------------------------------------------
;;;标记undo编组结束点
(defun EndUndoGroup()
(command "undo" "e")
)
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;; -------------------------------------------------------------------------
;;块统计.LSP
;;;--------------------------------------------------------------------------------
;;;从块选择集中选择指定块名的对象，并返回结果选择集
(defun intCountSingleBlock (ssOriginal strTargetBlockName /
strEntityName listEntityDXF strBlockName intSingleBlockCount k)
(setq intSingleBlockCount 0
k -1 )
(repeat (sslength ssOriginal) ; 循环与所选择的对象数量相等的次数
(setq strEntityName (ssname ssOriginal (setq k (1+ k)))) ; strEntityName，取得第k个对象名
(setq listEntityDXF (entget strEntityName))
(setq strBlockName (cdr (assoc 2 listEntityDXF)))
(if (= strBlockName strTargetBlockName)
(setq intSingleBlockCount (1+ intSingleBlockCount))
)
)
intSingleBlockCount
)
;;;--------------------------------------------------------------------------------
;;;从块选择集中删除指定块名的对象，并返回结果选择集
(defun ssDelEntitysFromBlockSelectionSet (ssOriginal strTargetBlockName
/ strEntityName listEntityDXF strBlockName ssResult k)
(setq ssResult (ssadd)
k -1 )
(repeat (sslength ssOriginal) ; 循环与所选择的对象数量相等的次数
(setq strEntityName (ssname ssOriginal (setq k (1+ k)))) ; strEntityName，取得第k个对象名
(setq listEntityDXF (entget strEntityName))
(setq strBlockName (cdr (assoc 2 listEntityDXF)))
(if (/= strBlockName strTargetBlockName)
(setq ssResult (ssadd strEntityName ssResult))
)
)
ssResult
)
;;;--------------------------------------------------------------------------------
;;;插入块缩略图
(defun PrintBlockMiniature (floatBasicPointX floatBasicPointY strBlockName
/ floatMaxBlockWidth floatMaxBlockHigh
floatBlockOriginalWidth floatBlockOriginalHigh floatBlockWidthScale
floatBlockHighScale floatBlockBoundingBoxTargetMinPointX
floatBlockBoundingBoxTargetMinPointY floatBlockBoundingBoxTargetMaxPointX
floatBlockBoundingBoxTargetMaxPointY listTargetBlockCenterPoint
listBlockBoundingBoxMinPoint listBlockBoundingBoxMaxPoint objectBlockEntity
strEntityName listInsertPoint floatBlockScale
listBlockEntityDXF listBlockCenterPoint
)
;; floatBasicPointX floatBasicPointY 缩略图所在表格单元左下角点坐标
;;计算图块缩略图在图中允许放置范围的左下及右上角点坐标的X、Y数值
(setq floatMaxBlockWidth 21
floatMaxBlockHigh 8
)
(setq floatBlockBoundingBoxTargetMinPointX (+ floatBasicPointX 2)
floatBlockBoundingBoxTargetMinPointY (+ floatBasicPointY 1)
floatBlockBoundingBoxTargetMaxPointX (+ floatBasicPointX floatMaxBlockWidth 2)
floatBlockBoundingBoxTargetMaxPointY (+ floatBasicPointY floatMaxBlockHigh 1)
)
(setq listTargetBlockCenterPoint (list (/ (+ floatBlockBoundingBoxTargetMinPointX floatBlockBoundingBoxTargetMaxPointX ) 2)
(/ (+ floatBlockBoundingBoxTargetMinPointY floatBlockBoundingBoxTargetMaxPointY ) 2 )
0
)
)
(setq listInsertPoint (list floatBlockBoundingBoxTargetMinPointX floatBlockBoundingBoxTargetMinPointY ) )
(InsertBlock strBlockName listInsertPoint 0)
;;以块缩略图允许放置范围的左下角点为块缩略图的基点插入图块
(setq strEntityName (entlast))
(setq objectBlockEntity (vlax-ename->vla-object strEntityName))
(if (vl-catch-all-error-p (vl-catch-all-apply 'vla-GetBoundingBox
(list objectBlockEntity 'listBlockBoundingBoxMinPoint 'listBlockBoundingBoxMaxPoint ))
) ;判断块是否存在边框，若块含无限长直线等时，则不存在边框
(AddText_AlignmentMiddle listBlockCenterPoint 3 0 "本块无缩略图" 0.8 "hztxt")
(progn
(setq listBlockBoundingBoxMinPoint (vlax-safearray->list listBlockBoundingBoxMinPoint) )
(setq listBlockBoundingBoxMaxPoint (vlax-safearray->list listBlockBoundingBoxMaxPoint) )
(if (> (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) )
(setq floatBlockWidthScale (/ floatMaxBlockWidth
(- (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) )
)
)
(setq floatBlockWidthScale 0)
)
(if (> (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) )
(setq floatBlockHighScale (/ floatMaxBlockHigh
(- (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) )
)
)
(setq floatBlockHighScale 0)
)
;计算块缩略图允许放置范围的边框长宽与块外框长宽的比值
(cond
((= (+ floatBlockWidthScale floatBlockHighScale) 0) (setq floatBlockScale 1)) ;块为单点时,缩放比例取为1
((= floatBlockWidthScale 0) (setq floatBlockScale floatBlockHighScale) ) ;块为竖直短线时
((= floatBlockHighScale 0) (setq floatBlockScale floatBlockWidthScale) ) ;块为水平短线时
((> floatBlockWidthScale floatBlockHighScale ) (setq floatBlockScale floatBlockHighScale) ) ;数值较小者为块的控制缩放比例
(T (setq floatBlockScale floatBlockWidthScale) )
)
(setq listBlockEntityDXF (entget strEntityName))
(entmod (subst (cons 41 floatBlockScale) (assoc 41 listBlockEntityDXF) listBlockEntityDXF ) )
(entupd strEntityName)
(setq listBlockEntityDXF (entget strEntityName))
(entmod (subst (cons 42 floatBlockScale) (assoc 42 listBlockEntityDXF) listBlockEntityDXF ) )
(entupd strEntityName)
(setq listBlockEntityDXF (entget strEntityName))
(entmod (subst (cons 43 floatBlockScale) (assoc 43 listBlockEntityDXF) listBlockEntityDXF ) )
(entupd strEntityName)
;;缩放块
(vla-GetBoundingBox objectBlockEntity 'listBlockBoundingBoxMinPoint 'listBlockBoundingBoxMaxPoint)
(setq listBlockBoundingBoxMinPoint (vlax-safearray->list listBlockBoundingBoxMinPoint) )
(setq listBlockBoundingBoxMaxPoint (vlax-safearray->list listBlockBoundingBoxMaxPoint) )
(setq listBlockCenterPoint (list (* 0.5 (+ (car listBlockBoundingBoxMaxPoint) (car listBlockBoundingBoxMinPoint) ) )
(* 0.5 (+ (cadr listBlockBoundingBoxMaxPoint) (cadr listBlockBoundingBoxMinPoint) ) )
0
)
)
(vla-move objectBlockEntity (vlax-3d-point listBlockCenterPoint) (vlax-3d-point listTargetBlockCenterPoint))
)
)
)
;;;--------------------------------------------------------------------------------
;;;打印统计结果表
(defun PrintCountResultList (listResult / i ListLength strBlockName
intNumberOfSSSingleBlockName strNumberOfSSSingleBlockName pt pt1
pt2 pt3 x y x1 y1
x2 x3 floatTextHigh
)
(setq pt (getpoint "\n点取要标注块统计结果信息的位置:"))
(setq x (car pt)
y (cadr pt)
i 0
floatTextHigh 4
)
(setq ListLength (length listResult))
(setq y1 (- y (* (1+ ListLength) 10))) ;行高取10
(while (<= i 3)
(setq x1 (+ x (* i 25))) ;列宽取25
(setq pt1 (list x1 y 0)
pt2 (list x1 y1 0)
)
(AddLine pt1 pt2)
(setq i (1+ i))
)
;;;画竖向表格线
(setq i 0)
(setq x1 (+ x (* 3 25)))
(while (<= i (1+ ListLength))
(setq y1 (- y (* i 10)))
(setq pt1 (list x y1 0)
pt2 (list x1 y1 0)
)
(AddLine pt1 pt2)
(setq i (1+ i))
)
;;;画横向表格线
;;;------------------------------------------------------------------------
(setq x1 (+ x (* 0.5 25))
x2 (+ x (* 1.5 25))
x3 (+ x (* 2.5 25))
y1 (- y 7)
)
(setq pt1 (list x1 y1 0)
pt2 (list x2 y1 0)
pt3 (list x3 y1 0)
)
(AddText_AlignmentMiddle pt1 floatTextHigh 0 "块缩略图" 0.8 "hztxt")
(AddText_AlignmentMiddle pt2 floatTextHigh 0 "块名称" 0.8 "hztxt")
(AddText_AlignmentMiddle pt3 floatTextHigh 0 "块数量" 0.8 "hztxt")
;;输出表头
;;;------------------------------------------------------------------------
(setq i 0
floatTextHigh 3 )
(while (< i ListLength)
(setq y1 (+ y (* -10 (+ i 2))))
(setq ;pt1 (list x1 y1 0)
pt2 (list x2 (+ y1 3) 0)
pt3 (list x3 (+ y1 3) 0)
)
(setq strBlockName (car (nth i listResult))
intNumberOfSSSingleBlockName (cadr (nth i listResult))
)
(setq strNumberOfSSSingleBlockName (itoa intNumberOfSSSingleBlockName))
(AddText_AlignmentMiddle pt2 floatTextHigh 0 strBlockName 0.8 "hztxt")
(AddText_AlignmentMiddle pt3 floatTextHigh 0 strNumberOfSSSingleBlockName 0.8 "hztxt")
(if (vl-catch-all-error-p (vl-catch-all-apply 'PrintBlockMiniature (list x y1 strBlockName)))
(AddText_AlignmentLeft (list (+ x 1) (+ y1 2)) 3 0 "生成块缩略图时出错" 0.8 "hztxt")
)
(setq i (1+ i))
)
;;;打印表内容
)
;;;--------------------------------------------------------------------------------
(defun GetBlocksSelectionRange (/ strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions listKeysToGetValue
listDCLReturn intButtonClick strSelectRange)
(setq strSelectRange "UserSelection" )
(setq strDCLFileName "BlocksSelectionRange")
(setq listInputDefinements '(("dialog" "指定统计范围" "")
("spacer")
("radio_column" "进行块统计的范围:")
("btRadio" "手工选择" "brUserSelection")
("btRadio" "整个图形" "brDrawingFile")
("end")
("text" "注:不统计含无限长直线的块!")
("spacer")
("btOK")
("end")
)
)
(setq listKeysAndValues '(("brUserSelection" "1")))
(setq listKeysAndActions '(("brUserSelection" "(setq strSelectRange \"UserSelection\")")
("brDrawingFile" "(setq strSelectRange \"DrawingFile\")")) )
(setq listKeysToGetValue nil)
(setq listDCLReturn (listGenerateDCL strDCLFileName listInputDefinements listKeysAndValues listKeysAndActions listKeysToGetValue) )
(setq intButtonClick (car listDCLReturn ) )
strSelectRange
)
;;;--------------------------------------------------------------------------------
;;;块数量统计
(defun tktj (/ ssObjects strEntityName listEntityDXF strBlockName
listResult intSingleBlockCount listMinPoint listInsertPoint floatBlockRotateAngle
;;listResult 用于记录统计结果，形式为(( 块名 块数量 同名块中一个实体的对象名 )...)
)
; (initget "D S _DrawingFile UserSelection")
; (setq strSelectRange (getkword "\n统计块的范围[全图(D)/选择(S)]<S>:"))
(setq strSelectRange (GetBlocksSelectionRange))
(if (= strSelectRange "DrawingFile")
(setq ssObjects (ssget "X" '((0 . "insert")(100 . "AcDbBlockReference")))) ; 创建选择集 ssObjects
(progn
(princ "\n请选择需要统计的块:\n")
(setq ssObjects (ssget '((0 . "INSERT")(100 . "AcDbBlockReference")))) ; 创建选择集 ssObjects
)
)
(if ssObjects
(progn
(setq listResult nil)
(while (> (sslength ssObjects) 0)
(setq strEntityName (ssname ssObjects 0)) ; strEntityName，取得第1个对象名
(setq listEntityDXF (entget strEntityName))
(setq strBlockName (cdr (assoc 2 listEntityDXF)))
(setq intSingleBlockCount (intCountSingleBlock ssObjects strBlockName ) )
(setq ssObjects (ssDelEntitysFromBlockSelectionSet ssObjects strBlockName))
(setq listResult (append listResult
(list (list strBlockName intSingleBlockCount))
)
)
)
(setvar "dimzin" 8)
(setvar "osmode" 0)
(if (tblsearch "style" "hztxt")
;;判断是否存在"hztxt"字体，有则设为当前，无则创建。
(setvar "textstyle" "hztxt")
(command "_style" "hztxt" "sceie.shx,sceic.shx" 0 0.8 0 "N" "N" "N")
)
(PrintCountResultList listResult)
(setvar "osmode" 16383)
)
)
(princ)
)
(defun c:ktj()(dim_scei_tktj))
;;;--------------------------------------------------------------------------------
[复制链接]
发表于 2010-7-12 11:00:00
置顶卡
变色卡
显身卡
楼主