cad自动写标高lisp

合集下载

浅谈建筑标高在Auto CAD中自动绘制

浅谈建筑标高在Auto CAD中自动绘制摘要:使用Auto CAD中的动态块和AutoLISP&DCL(Dialogue Control Language)实现建筑标高的自动绘制。

关键词:标高动态块AutoCAD AutoLISP DCL在机械、建筑等领域常使用Auto CAD进行图形绘制,绘图过程中有很多重复性工作要做,例如建筑中的门、窗、标高。

为此Auto CAD 绘图软件为我们提供了图块功能,把门、窗、标高做成图块,使用只需要插入或复制即可,大大降低了劳动强度。

但是在绘图过程中有不同开度,不同尺寸的门,有标注在平面图上的标高,有标注在立面图上的标高,只使用图块还难适应不同场合的需求。

这时我们可以使用Auto LISP或动态块功能,当然我们还可以使用建筑领域的专业绘图软件天正系列、PKPM等。

本文以建筑标高为例阐述Auto CAD的动态块和Auto LISP与对话框控制语言DCL的使用。

1 使用动态块实现建筑标高1.1 动态块简介Auto CAD从2006版引入动态块功能,所谓动态块就是按预先设定好的状态进行变化的图块。

从动态块的定义可知创建图块是实现动态块的基础,所以我们要先会创建图块。

所谓图块是将多个对象组合起来形成单个对象的对象集合。

1.2 建筑标高根据《房屋建筑制图标准应用手册》[1],标高符号以直角等腰三角形表示,如图1。

其中图(a)为个体建筑物的标高符号,若标注位置不够可使用图(b)形式,图(c)为总平面室外地坪标高符号;图(d)、(e)为带高度引出线的标高。

1.3 实现步骤为了实现方便将图1中的(a)、(d)归为一组,(b)、(e)为一组,(c)单独一组或者将(c)整合到前两组中。

因为实现方法大概一致,我选择(b)、(e)这组表述。

具体分6个步骤完成动态块设计[2],第1步:在创建动态块之前规划动态块的内容。

第2步:绘制几何图形。

第3步:了解块元素如何共同作用。

CAD定制命令和脚本方法讲解

CAD定制命令和脚本方法讲解CAD（Computer-Aided Design）是一款非常强大的绘图软件，广泛应用于建筑设计、土木工程、机械制图等领域。

为了更高效地使用CAD，定制命令和脚本方法成为了许多用户的首选。

在本文中，我们将介绍CAD的定制命令和脚本方法，并提供一些实用的技巧和示例。

一、定制命令定制命令是指根据用户的需求，在CAD中创建自定义的命令，以便更快捷地完成某些特定的操作。

在CAD中，我们可以使用Lisp语言来编写自定义命令。

1. 创建Lisp文件首先，打开任意文本编辑器，如记事本，然后创建一个新的Lisp文件。

保存文件时，将文件扩展名设置为.lsp，以便CAD能够正确地识别它。

2. 编写Lisp代码在Lisp文件中，我们可以编写自定义命令的代码。

例如，我们可以创建一个名为"Rectangle"的命令，用于绘制矩形。

以下是一个简单的例子：(defun c:Rectangle () ;定义命令名称为Rectangle(command "RECTANG" pause) ;调用CAD内置命令RECTANG)在上述代码中，defun c:Rectangle ()表示定义一个名为Rectangle的命令。

command "RECTANG" pause表示调用CAD内置命令RECTANG，并在每次绘制矩形后暂停。

3. 加载并运行命令将保存好的Lisp文件加载到CAD中，有两种方式可以实现：a. 使用APPLOAD命令：在CAD的命令行中输入APPLOAD，然后选择加载Lisp文件。

b. 使用加载项管理器：在CAD界面中，选择"工具"-"加载项"打开加载项管理器，然后点击"添加"按钮选择加载Lisp文件。

加载完成后，我们可以通过在CAD命令行中输入Rectangle命令来执行自定义命令。

cad lisp编程的一些指令

构造线xline指定点或[水平(H)/垂直(V)/角度(A)/二等分(B)/偏移(O)]: h 指定通过点:多段线pline指定起点: 指定下一个点或[圆弧(A)/半宽(H)/长度(L)/放弃(U)/宽度(W)]:正多边形polygon 输入边的数目<4>: 指定正多边形的中心点或[边(E)]: 输入选项[内接于圆(I)/外切于圆(C)] <I>: 指定圆的半径:矩形rectang指定第一个角点或[倒角(C)/标高(E)/圆角(F)/厚度(T)/宽度(W)]: 指定另一个角点或[面积(A)/尺寸(D)/旋转(R)]:圆弧arc指定圆弧的起点或[圆心(C)]: 指定圆弧的第二个点或[圆心(C)/端点(E)]: 指定圆弧的端点:圆circle指定圆的圆心或[三点(3P)/两点(2P)/切点、切点、半径(T)]: 指定圆的半径或[直径(D)]:修订云线Revcloud最小弧长: 15最大弧长: 15样式: 普通指定起点或[弧长(A)/对象(O)/样式(S)] <对象>: 沿云线路径引导十字光标...反转方向[是(Y)/否(N)] <否>:样条曲线spline指定第一个点或[对象(O)]: 指定下一点: 指定下一点或[闭合(C)/拟合公差(F)] <起点切向>:指定起点切向: 指定端点切向:椭圆ellipse指定椭圆的轴端点或[圆弧(A)/中心点(C)]: 指定轴的另一个端点: 指定另一条半轴长度或[旋转(R)]: 椭圆弧ellipse指定椭圆的轴端点或[圆弧(A)/中心点(C)]: a 指定椭圆弧的轴端点或[中心点(C)]: 指定轴的另一个端点: 指定另一条半轴长度或[旋转(R)]: 指定起始角度或[参数(P)]: 指定终止角度或[参数(P)/包含角度(I)]:插入块insert 块定义block 创建多个点对象point 图案填充hatch 渐变色gradient 面域region 表格table 多行文字mtext 当前文字样式: "Standard"文字高度: 2.5 注释性: 否指定第一角点: 指定对角点或[高度(H)/对正(J)/行距(L)/旋转(R)/样式(S)/宽度(W)/栏(C)]:删除erase 分解explode 前置draworder复制copy 选择对象: 找到 1 个当前设置: 复制模式= 多个指定基点或[位移(D)/模式(O)] <位移>: 指定第二个点或[退出(E)/放弃(U)] <退出>: 指定第二个点或[退出(E)/放弃(U)] <退出>:镜像mirror 选择对象: 1 个指定镜像线的第一点: 指定镜像线的第二点: 要删除源对象吗？[是(Y)/否(N)] <N>: y阵列array 选择对象: 找到 1 个偏移offset 当前设置: 删除源=否图层=源OFFSETGAPTYPE=0指定偏移距离或[通过(T)/删除(E)/图层(L)] <通过>: 指定第二点:选择要偏移的对象，或[退出(E)/放弃(U)] <退出>: 移动move选择对象: 找到 1 个指定基点或[位移(D)] <位移>: 指定第二个点或<使用第一个点作为位移>:旋转rotate UCS 当前的正角方向: ANGDIR=逆时针ANGBASE=0选择对象: 找到1 个指定基点: 指定旋转角度，或[复制(C)/参照(R)] <0>:缩放scale 选择对象: 找到 1 个指定基点: 指定比例因子或[复制(C)/参照(R)] <1.0000>:拉伸stretch以交叉窗口或交叉多边形选择要拉伸的对象...选择对象: 找到1 个指定基点或[位移(D)] <位移>: 指定第二个点或<使用第一个点作为位移>:修剪trim选择剪切边... 选择对象或<全部选择>: 找到1 个选择要修剪的对象，或按住Shift 键选择要延伸的对象，或[栏选(F)/窗交(C)/投影(P)/边(E)/删除(R)/放弃(U)]:延伸extend 当前设置:投影=UCS，边=无选择边界的边... 选择对象或<全部选择>: 找到 1 个选择要延伸的对象，或按住Shift 键选择要修剪的对象，或[栏选(F)/窗交(C)/投影(P)/边(E)/放弃(U)]: 指定对角点:打断于点break选择对象: 指定第二个打断点或[第一点(F)]: _f 指定第一个打断点: 指定第二个打断点: @打断break 选择对象: 指定第二个打断点或[第一点(F)]: 需要点或选项关键字。

CAD中添加LISP

CAD技巧：中望CAD中加载LISP程序1、首先请加载lisp程序，加载方法如下：在菜单栏选择工具——加载应用程序——添加，选择lisp程序然后加载，然后选择添加到启动组。

(其他lisp使加载方式相同)2、然后是添加自定义栏以及图标，方法如下（以坐标标注为例，其余操作相同）：在软件右上方空白区右键选择自定义——工具栏——新建——（修改名称）确定（以下操作均是在不关闭自定义前提下的操作）。

此时在左侧图层工具栏下面会出现一个空白工具栏，然后在命令里面，随便找一个图标（例如新建、打开等等以下以新建为例）拖放入新建的空白工具栏里，右键点击拖放在空白工具栏里的图标，选修改。

在弹出对话框里有名称、命令、说明三项可以修改。

其中将命令“^C^C_new”修改为“^C^C_zbbz”，将名称修改为“坐标标注”，然后确定。

再次右键点击此图标，选择编辑按钮图像，工具一栏最后一个命令图标Import From File。

选择坐标标注所对应的图标打开然后确定。

3、在使用了自定义工具栏后可能需要将这些工具栏导出给其他同事使用，这是就需要将工具栏导出，导出和导入方法如下：导出:在自定义完工具栏后，选择工具——自定义——工具栏然后导出，在选项框里将刚才自定义的勾选，其他象不选择，否则会出现重复，然后确定，选择XML工具条文件（xml）格式保存。

导入：加载工具栏文件：选择工具——自定义——工具栏，选择导入，文件类型选择XML工具条文件（xml），选择然后打开。

要注意的地方是：其他命令操作与以上相用，所加载的lisp程序与图片所在文件夹为固定文件夹，不可修改，否则不能调用其命令，加载lisp程序后一定要选择“添加到启动组”，否则软件启动后不能自己加载此lisp程序。

以上是在中望 CAD中加载LISP程序的具体挂接方法，除开LISP，中望 CAD还提供了VBA、SDS以及DRX（类ARX）接口，用户可以针对自己的使用要求，优化、改善软件使用功能、方式，中望CAD2009的推出，让中望 CAD的扩展接口特别是DRX接口更加完善，并已成功应用到与天河软件、清华斯维尔建筑、鸿业暖通给排水等二次开发的合作中去。

CAD_XY坐标标注AUTO_LISP程序-15页文档资料

CAD X,Y坐标坐标标注AUTO LISP程序;; (DEFUN IDPT(/ p px py pxx pyy)(DEFUN IDPT ()(SETQ X T)(WHILE X(SETV AR "OSMODE" (+ 1 32 512))(INITGET 1)(SETQ PP (GETPOINT "\nPLEASE PICK THE POINT:")) (SETV AR "OSMODE" 0)(SETQ P (OSNAP PP "INT,END,CEN"))(IF (= P NIL)(PROMPT "\nINV ALID POINT, PICK !")(SETQ X NIL)(SETQ PXX (CAR P)PYY (CADR P)PX (RTOS PXX 2 PRE1)PY (RTOS PYY 2 PRE1);;(DEFUN MAX_XY(WI PX PY / L PXPX PYPY) (DEFUN MAX_XY ()(SETQ KKK "X")(SETQ LLL "Y")(SETQ LX (STRLEN PX)L Y (STRLEN PY)(IF (> LX L Y)(PROGN(SETQ W_NU (- LX L Y))(WHILE (> W_NU 0)(SETQ PY (STRCAT " " PY))(SETQ W_NU (- W_NU 1))(IF (< LX L Y)(PROGN(SETQ W_NU (- L Y LX))(WHILE (> W_NU 0)(SETQ PX (STRCAT " " PX))(SETQ W_NU (- W_NU 1))(SETQ PYPY (STRCAT KKK PY))(SETQ PXPX (STRCAT LLL PX))(SETQ PXL (STRLEN PXPX)PYL (STRLEN PYPY)MAXL (FLOAT (MAX PXL PYL))L (* WI MAXL);;(DEFUN TEXT_P(/ W WX WY)(DEFUN TEXT_P ()(SETV AR "OSMODE" 0)(INITGET 1)(SETQ W (GETPOINT "\nINPUT X-Y TEXT POSITION:")) (SETQ WX (CAR W))(SETQ WY (CADR W));;(DEFUN DRLIN(CAL P W L / ALPW WE)(DEFUN DRLIN ()(SETQ AL01 (+ PI CAL))(SETQ ALPW (ANGLE P W))(SETQ AG-D (- ALPW CAL))(IF (> AG-D 0)(PROGN(IF (AND (< AG-D (* PI 0.5)) (> AG-D (* PI 0)))(SETQ WE (POLAR W CAL L)BZ 1(IF (AND (> AG-D (* PI 0.5)) (< AG-D (* PI 1.5)))(SETQ WE (POLAR W AL01 L)BZ 2(IF (AND (> AG-D (* PI 1.5)) (< AG-D (* PI 2)))(SETQ WE (POLAR W CAL L)BZ 3(PROGN(IF (AND (> AG-D (* PI -0.5)) (< AG-D (* PI 0)))(SETQ WE (POLAR W CAL L)BZ 1(IF (AND (< AG-D (* PI -0.5)) (> AG-D (* PI -1.5)))(SETQ WE (POLAR W AL01 L)BZ 2(IF (AND (< AG-D (* PI 1.5)) (> AG-D (* PI -2)))(SETQ WE (POLAR W CAL L)BZ 3(COMMAND "PLINE" P "W" 0.0 "" W WE "");;(DEFUN DRCORD(AL01 ALPW H CAL PXPX PYPY /) (DEFUN DRCORD ()(IF (= BZ 2)(SETQ WB WE)(SETQ WB W)(SETQ WBX (POLAR WB (+ (* PI 0.5) CAL) H)WBY (POLAR WB (+ (* PI 1.5) CAL) H)(SETQ AL_CAL (* 180 (/ CAL PI)))(COMMAND "TEXT" "J" "ML" WBX H AL_CAL PYPY) (COMMAND "TEXT" "J" "ML" WBY H AL_CAL PXPX) ;;(DEFUN DRELEV(AL01 ALPW WE CAL WI PRE2) (DEFUN DRELEV ()(IF (< WX PXX)(SETQ EPL (POLAR WE AL01 (* WI 0.5)))(SETQ EPR (POLAR WE CAL (* WI 0.5)))(SETQ DHH (GETREAL "\nINPUT DESIGN ELEV A TION:"))(IF (= DHH NIL)(PROMPT "\nNO ELEV ATION A V AILABLE NOW!")(PROGN(SETQ DH (RTOS DHH 2 PRE2))(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "ELEV")(ELA)(IF (< WX PXX)(COMMAND "TEXT" "J" "MR" EPL H AL_CAL DH)(COMMAND "TEXT" "J" "ML" EPR H AL_CAL DH)(DEFUN PCR ()(SETQ TS 0.0)(SETV AR "OSMODE" 33)(SETQ X T)(WHILE X(INITGET 1)(SETQ PP1 (GETPOINT "\nENTER THE FIRST POINT:"))(SETQ P1 (OSNAP PP1 "INT,END"))(IF (/= P1 NIL)(SETQ X NIL)(PROGN (PROMPT "\nNO INT OR END FOUND, CONTINUE? [Y/N]") (INITGET 1)(SETQ J (GETSTRING))(IF (OR (= J "Y") (= J "y"))(PROGN (SETQ P1 PP1) (SETQ X NIL))(PROMPT "\nRESELECT PLEASE!")(SETQ OP1 P1)(SETQ P_NUMBER 1)(SETQ X T)(WHILE X(SETQ P_NUMBER (+ 1 P_NUMBER))(SETQ PRO_1 (STRCAT "\n THE <" (ITOA P_NUMBER)))(SETQ PRO_1 (STRCAT PRO_1 "> POINT(ENTER=END SELECT:)"))(SETQ P2 (GETPOINT PRO_1))(IF (/= P2 NIL)(PROGN (SETQ SS(* (+ (CADR P1) (CADR P2)) (- (CAR P2) (CAR P1)) 0.5) (SETQ TS (+ TS SS))(SETQ P1 P2)(PROGN (SETQ SS(* (+ (CADR OP1) (CADR P1)) (- (CAR OP1) (CAR P1)) 0.5)(SETQ TS (+ TS SS))(SETQ X NIL)(SETQ S0 (ABS TS))(SETQ TSS (RTOS S0 2 PRE3))(SETV AR "OSMODE" 0)(INITGET 1)(SETQ W (GETPOINT "\nINPUT TEXT POSITION:")) (COMMAND "TEXT" W H 0.0 (STRCAT "S=" TSS))(DEFUN ETP ()(SETQ X T)(WHILE X(PROMPT "\nSELECT EDGE OF THE POL YGON:")(SETQ S_SET (SSGET))(IF (= S_SET NIL)(PROMPT "\nINV ALID SELECTION, RESELECT PLEASE!")(SETQ X NIL)(CA_AREA)(DEFUN LTP ()(INITGET 1)(SETQ URC (GETCORNER(SETQ DLC (GETPOINT "\nENTER FIRST CORNER:"))"\nTHE SECOND CORNER:"(SETQ SSET (SSGET "W" DLC URC))(COND((OR (= ENTP "LINE") (= ENTP "ARC"))(COMMAND "PEDIT" (SSGET P10) "Y" "J" SSET "" "X")((= ENTP "POL YLINE")(COMMAND "PEDIT" (SSGET P10) "J" SSET "" "X")(T (PROMPT "\nINV ALID ENTITY FOR PEDIT!"))(DEFUN RETP ()(SETQ SET1 (SSGET P10))(SETQ ENAME (SSNAME SET1 0))(SETQ ELIST (ENTGET ENAME))(SETQ ENTP (CDR (ASSOC 0 ELIST)))(DEFUN PLTP ()(SETQ ENTP2 (CDR (ASSOC 70 ELIST)))(DEFUN PLS ()(PLTP)(IF (= ENTP2 1)(PROGN (REDRAW ENAME 3)(PROMPT "\nIT'S A CLOSED POL YLINE")(S)(PROGN(REDRAW ENAME 3)(PROMPT "\nIT'S NOT A CLOSED PLINE, TRY TO CLOSE IT!")(LTP)(RETP)(PLTP)(IF (= ENTP2 1)(PROGN (PROMPT "\nNOW IT HAS BEEN CLOSED!")(S)(PROGN (REDRAW ENAME 3)(SETQ X(GETSTRING(STRCAT"\nCAN'T BE CLOSED AUTOMA TICALL Y, CALCULATE IST AREA?""\n<'Y' FOR YES AND ANY OTHER KEY FOR NO>"(IF (OR (= X "Y") (= X "y"))(S)(PROMPT "\nTHIS ONE IGNORED, CALCULATE NEXT POL YGON!") (DEFUN S ()(COMMAND "AREA" "E" (SSGET P10))(SETQ SS (GETV AR "AREA"))(SETQ S1 (RTOS SS 2 PRE3))(SETV AR "OSMODE" 0)(INITGET 1)(SETQ PT (GETPOINT "\nINPUT TEXT POSITION:"))(COMMAND "TEXT" PT H 0.0 (STRCAT "S=" S1))(DEFUN THN ()(IF (/= B0 NIL)(PROGN(SETQ BI (RTOS B0 2 1))(INITGET 6)(SETQB (GETREAL(STRCAT "\nINPUT MAP SCALE FACTOR [1:X*1000]/<" BI ">")(IF (= B NIL)(SETQ B B0)(SETQ B0 B)(PROGN(INITGET 7)(SETQ B (GETREAL "\nINPUT MAP SCALE FACTOR [1:X*1000]"))(SETQ B0 B)(IF (/= CAL0 NIL)(PROGN(SETQ CAL1 (RTOS CAL0 2 1))(INITGET 8)(SETQ CAL2 (GETREAL(STRCAT "\nINPUT TEXT ROTATE ANGLE[d]/<" CAL1 ">") (IF (= CAL2 NIL)(SETQ CAL (/ (* PI CAL0) 180))(PROGN(SETQ CAL (/ (* PI CAL2) 180))(SETQ CAL0 CAL2)(PROGN (INITGET 8)(SETQ CAL2 (GETREAL "\nINPUT TEXT ROTATE ANGLE[d]:"))(SETQ CAL (/ (* PI CAL2) 180))(SETQ CAL0 CAL2)(IF (/= HH0 NIL)(PROGN(SETQ HHI (RTOS HH0 2 1))(INITGET 6)(SETQ HH (GETREAL(STRCAT "\nINPUT TEXT HEIGHT [mm]/<" HHI ">")(IF (= HH NIL)(SETQ HH HH0)(SETQ HH0 HH)(PROGN (INITGET 7)(SETQ HH (GETREAL "\nINPUT TEXT HEIGHT [MM]:"))(SETQ HH0 HH)(SETQ H (* HH B))(IF (= WF NIL)(SETQ WF 1.0)(SETQ WI (* H WF))(DEFUN PRE1N ()(IF (/= PRE10 NIL)(PROGN (SETQ PRE1I (RTOS PRE10 2 0))(INITGET 4)(SETQPRE1 (GETINT(STRCA T "\nINPUT DECIMAL PLACE FOR X-Y COORDINATE <"PRE1I(IF (= PRE1 NIL)(SETQ PRE1 PRE10)(SETQ PRE10 PRE1)(PROGN (INITGET 5)(SETQ PRE1(GETINT "\nINPUT DECIMAL PLACE FOR X-Y COORDINATE:") (SETQ PRE10 PRE1)(DEFUN PRE2N ()(IF (/= PRE20 NIL)(PROGN (SETQ PRE2I (RTOS PRE20 2 0))(SETQ PRE2 (GETINT(STRCAT "\nINPUT DECIMAL PLACE FOR ELEV ATION <"PRE2I(IF (= PRE2 NIL)(SETQ PRE2 PRE20)(SETQ PRE20 PRE2)(PROGN (INITGET 5)(SETQ PRE2(GETINT "\nINPUT DECIMAL PLACE FOR ELEV A TION:")(SETQ PRE20 PRE2)(DEFUN PRE3N ()(IF (/= PRE30 NIL)(PROGN (SETQ PRE3I (RTOS PRE30 2 0))(INITGET 4)(SETQ PRE3(GETINT(STRCA T "\nINPUT DECIMAL PLACE FOR AREA IDENTIFICATION <"PRE3I(IF (= PRE3 NIL)(SETQ PRE3 PRE30)(SETQ PRE30 PRE3)(PROGN (INITGET 5)(SETQ PRE3(GETINT "\nINPUT DECIMAL PLACE FOR AREA IDENTIFICATION:") (SETQ PRE30 PRE3)(DEFUN XYZ ()(THN)(PRE1N)(PRE2N)(SETQ XX T)(WHILE XX(INITGET "Exit Continue")(SETQ ZZ (GETKWORD "\nExit/Continue?/<Continue>"))(COND((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC)((OR (= ZZ NIL) (= ZZ "Continue"))(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "CORD")(XYLA)(IDPT);; (MAX_XY WI PX PY L)(MAX_XY);; (DRLIN CAL P W L)(DRLIN);; (DRCORD AL01 ALPW H CAL PXPX PYPY)(DRCORD);; (DRELEV AL01 ALPW WE CAL WI PRE2)(DRELEV)(DEFUN FIX ()(THN)(PRE1N)(PRE2N)(SETQ XX2 T)(WHILE XX2(SETQ XX3 NIL)(IDPT)(ALN1)(SETQ XX T)(WHILE XX(INITGET "Help Exit COntinue CHangepar")(SETQ ZZ (GETKWORD "\nHelp/Exit/COntinue/CHangepar?/<COntinue>"))(COND((= ZZ "Help")(TEXTPAGE)(PROMPT"\n ENTER A V ALUE OR A POINT TO DEFINE THE LENGTH OF OBLIQUAL BASELINE AND"(PROMPT"\nENTER A POINT IN ONE OF THE FOUR QAUDRANTS TO SELECT THE DIRECTION OF THE "(PROMPT"\nOBLIQUAL BASELINE OR PRESS 'ENTER' TO SELECT THE DEFAULT V ALUES."((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NILXX2 NIL(PRINC)((OR (= ZZ NIL) (= ZZ "Continue"))(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "CORD")(XYLA)(IF (= XX3 T)(SETQ XX3 T)(CPXY)(ALN2)(TBL)(CORD)(DE)((= ZZ "CHangepar") (SETQ XX NIL))(DEFUN AE ()(ELA)(THN)(PRE2N)(SETQ XX T)(WHILE XX(INITGET "Help Exit Continue")(SETQ ZZ (GETKWORD "\nHelp/Exit/Continue?/<Continue>"))(COND((= ZZ "Help")(TEXTPAGE)(PROMPT"\n FIRST SELECT THE ID POINT, THEN SELECT THE END OF THE"(PROMPT "\nHORIZONTAL BASELINE;")((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC)((OR (= ZZ NIL) (= ZZ "Continue"))(SETV AR "OSMODE" 1)(SETQ PP (GETPOINT "\nSELECT THE ID POINT:"))(SETQ P (OSNAP PP "END"))(SETQ PXX (CAR P))(SETQ X T)(WHILE X(SETQ WEE (GETPOINT "\nINPUT THE TEXT POSITION:"))(SETQ WE (OSNAP WEE "END"))(IF (= WE NIL)(PROMPT "\nINV ALID POSITION, RESELECT PLEASE!")(SETQ X NIL)(SETQ WX (CAR WE))(SETV AR "OSMODE" 0)(DE)(DEFUN PLGS ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA)(THN)(PRE3N)(ETP)(SETV AR "osmode" 0)(INITGET 1)(SETQ PT (GETPOINT "\n Please input TEXT POSITION:")) (COMMAND "text"PTH0.0(STRCAT "S=" S_AREA)(DEFUN CA_AREA ()(SETQ ENT_NAME (SSNAME S_SET 0))(SETQ ENT_NUM (SSLENGTH S_SET))(SETQ T_AREA 0LOOP 0NUM 0(WHILE LOOP(COMMAND "AREA" "E" ENT_NAME)(SETQ S1_AREA (LIST (GETV AR "AREA")))(SETQ S2_AREA (CAR S1_AREA))(SETQ T_AREA (+ T_AREA S2_AREA))(SETQ NUM (+ NUM 1))(SETQ ENT_NAME (SSNAME S_SET NUM))(IF (= NUM ENT_NUM)(SETQ LOOP NIL)(SETQ S_AREA (RTOS T_AREA 2 PRE3))(DEFUN E_LAYER ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA)(THN)(PRE3N)(SETQ L_NAME (GETSTRING "\nPlaese input LAYER NAME:")) (SETQ S_SET (SSGET "X"(LIST (CONS 0 "POL YLINE")(CONS 8 L_NAME)(CA_AREA)(SETV AR "osmode" 0)(INITGET 1)(SETQ PT (GETPOINT "\n Please input TEXT POSITION:")) (COMMAND "text"PTH0.0(STRCAT "The layer<" L_NAME ">S=" S_AREA)(DEFUN E_COLOR ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA)(THN)(PRE3N)(SETQ C_NAME (GETINT "\nPlaese input COLOR NAME:"))(SETQ S_SET (SSGET "X"(LIST (CONS 0 "POL YLINE")(CONS 62 C_NAME)(CA_AREA)(SETV AR "osmode" 0)(INITGET 1)(SETQ PT (GETPOINT "\n Please input TEXT POSITION:"))(COMMAND "text"PTH0.0(STRCAT "The color <" (RTOS C_NAME 2 0) ">S=" S_AREA) (DEFUN POS ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA)(THN)(PRE3N)(SETQ XX T)(WHILE XX(INITGET "Help Exit Continue")(SETQ ZZ (GETKWORD "\nHelp/Exit/Continue?/<Continue>"))(COND((= ZZ "Help")(TEXTPAGE)(PROMPT"\n ENTER THE POINTS TO DEFINE THE EDGE OF THE REGION"(PROMPT"\nTO BE CALCULATED AND IDed, AFTER LAST POINT ENTERED,"(PROMPT"\nPRESS 'ENTER' AND THEN SELECT A POINT TO DEFINE THE"(PROMPT "\nPOSITION OF THE AREA ID TEXT.")((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC)((OR (= ZZ NIL) (= ZZ "Continue"))(PCR)(DEFUN XYLA ()(COMMAND "LAYER" "M" "CORD" "C" "CYAN" "" "")(DEFUN ELA ()(COMMAND "LAYER" "M" "ELEV" "C" "CYAN" "" "")(DEFUN SLA ()(COMMAND "LAYER" "M" "AREA" "C" "CYAN" "" "")(DEFUN ALN1 ()(IF (/= AL0 NIL)(PROGN (SETQ ALI (RTOS AL0 2 1))(INITGET 70)(PROMPT(STRCAT "\nINPUT OBLIQUAL LINE LENGTH [DRAWING UNIT]/<"ALI(SETQ ALL (GETDIST P))(IF (= ALL NIL)(SETQ ALL AL0)(SETQ AL0 ALL)(PROGN (INITGET 71)(SETQ ALL (GETDIST P"\nINPUT OBLIQUAL LINE LENGTH [DRAWING UNIT]"(SETQ AL0 ALL)(IF (/= WA0 NIL)(PROGN(SETQ WAI (ANGTOS W A0 0 0))(PROMPT(STRCAT "\nCHOOSE THE DIRECTION OF THE OBLIQUAL LINE<"WAI"d>:"(SETQ DRL (GETANGLE P))(IF (= DRL NIL)(SETQ W A WA0)(PROGN(COND((< DRL (* PI 0.5))(SETQ W A (* PI 0.25))((< DRL PI)(SETQ W A (* PI 0.75))((< DRL (* PI 1.5))(SETQ W A (* PI 1.25))((< DRL (* PI 2.0))(SETQ W A (* PI 1.75))(SETQ WA0 W A)(PROGN (INITGET 1)(SETQDRL (GETANGLE P"\nCHOOSE THE DIRECTION OF THE OBLIQUAL LINE:"(COND((< DRL (* PI 0.5))(SETQ WA (* PI 0.25))((< DRL PI)(SETQ WA (* PI 0.75))((< DRL (* PI 1.5))(SETQ WA (* PI 1.25))((< DRL (* PI 2.0))(SETQ WA (* PI 1.75))(SETQ WA0 WA)(DEFUN ALN2 ()(SETQ W (POLAR P (+ CAL WA) ALL))(SETQ WX (CAR W))(DEFUN TSET ()(SETV AR "FILEDIA" 0)(SETQ WFF (GETREAL"\nINPUT THE WIDTH-HEIGHT FACTOR OF TEXT<1.0>:"(IF (= WFF NIL)(SETQ WF 1.0)(SETQ WF WFF)(COMMAND "STYLE" "STANDARD" "MONOTXT" "0.0" WF "0" "N" "N" "N") (SETV AR "FILEDIA" 1)(COMMAND "COLOR" "BYLAYER")(PRINC)(DEFUN CO-ZOOM ()(PROMPT "\nTURN OFF ALL UNCONCERN LAYERS!")(IF (/= CS0 NIL)(PROGN (SETQ CSI (RTOS CS0 2 1))(INITGET 6)(PROMPT (STRCAT "\nINPUT CURRENT SCALE FACTOR<" CSI ">:"))(SETQ CS (GETREAL))(IF (= CS NIL)(SETQ CS CS0)(SETQ CS0 CS)(PROGN (SETQ CS (GETREAL "\nINPUT CURRENT SCALE FACTOR:")) (SETQ CS0 CS)(IF (/= DS0 NIL)(PROGN (SETQ DSI (RTOS DS0 2 1))(PROMPT (STRCAT "\nINPUT PREFER SCALE FACTOR<" DSI ">:"))(SETQ DS (GETREAL))(IF (= DS NIL)(SETQ DS DS0)(SETQ DS0 DS)(PROGN (SETQ DS (GETREAL "\nINPUT PREFER SCALE FACTOR:")) (SETQ DS0 DS)(SETQ FTOR (/ DS CS))(SETQ XX T)(WHILE XX(INITGET "Help Exit Continue")(SETQ ZZ (GETKWORD "\nHelp/Exit/Continue?/<Continue>"))(COND((= ZZ "Help")(TEXTPAGE)((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC)((OR (= ZZ NIL) (= ZZ "Continue"))(SETV AR "OSMODE" 32)(INITGET 1)(SETQ P (GETPOINT "\SELECT THE ID BASELINE:"))(SETQ PP (OSNAP P "END,INS"))(SETQ P2 (GETCORNER(SETQ P1 (GETPOINT "\nSELECT TEXTs IN WINDOW:")) (SETQ SSET (SSGET "W" P1 P2))(COMMAND "SCALE" SSET "" PP FTOR)(DEFUN HLP ()(PROMPT "\n")(defun-q *error* () ("PROGRAM TERMINATED BY USER")(PRINC "\nERROR: ")(PRINC "PROGRAM TERMINA TED BY USER!")(PRINC)(DEFUN C:DM ()(PRINC)(SETQ CULA (GETV AR "CLAYER"))(SETQ XXX T)(SETQ ZP "3d")(WHILE XXX(INITGET"Help Set 3D F3d Ae APOint APLine ALayer AColor Coz Exit"(SETQ"\nHelp/Set/3D/F3d/Ae/APOint/APLine/ALayer/AColor/Coz/Exit:" (SETQ ZP1 Z)(IF (= Z NIL)(SETQ Z ZP)(SETQ ZP ZP1)(COND((= Z "Help") (HLP))((= Z "Set") (TSET))((= Z "3D") (XYZ))((= Z "F3d") (FIX))((= Z "APOint") (POS))((= Z "APLine") (PLGS))((= Z "ALayer") (E_LAYER))((= Z "AColor") (E_COLOR))((= Z "Coz") (CO-ZOOM))((= Z "Ae") (AE))((= Z "Exit")(COMMAND "LAYER" "S" CULA "")(PROMPT "\n *** Exit from DM program, Thanks! ***")(SETQ XXX NIL)(PRINC)。

CAD LISP 程序教学内容

C AD L I S P程序1.计算所有线段总长度(加载后只需框选所有线段便可得出这些线段的总长度) (defun c:LL ()(setvar "cmdecho" 1)(setq en (ssget (list '(0 . "spline,arc,line,ellipse,LWPOLYLINE"))))(setq i 0)(setq ll 0)(repeat (sslength en)(setq ss (ssname en i))(setq endata (entget ss))(command "lengthen" ss "")(setq dd (getvar "perimeter"))(setq ll (+ dd ll))(setq i (1+ i)))(princ "所选线条总长为：")(princ ll)(princ))2.标注所有线段(加载后只需框选所有线段便可得标注这些线段)(defun c:LLL ()(COMMAND "UCS" "")(setvar "cmdecho" 1)(SETVAR "OSMODE" 0)(setq AcadObject (vlax-get-acad-object)AcadDocument (vla-get-ActiveDocument Acadobject)mSpace (vla-get-ModelSpace Acaddocument));;选取需要测量的样条曲线、圆弧、直线、椭圆(setq en (ssget (list '(0 . "spline,arc,line,ellipse,LWPOLYLINE")))) (setq i 0);;获取系统参数textsize(setq shh (getvar "textsize"))(setq str_hh (strcat "\n文字高度<" (rtos shh 2) ">: "))(setq hh (getdist str_hh))(while hh(setvar "textsize" hh)(setq hh nil));;输入标注文字高度;;循环开始(repeat (sslength en)(setq ss (ssname en i))(setq endata (entget ss))(command "lengthen" ss "")(setq dd (getvar "perimeter"))(princ (strcat "\n长度=" (rtos dd 2)));;寻找代表图层的字符串(setq aa (assoc 0 endata));;获取图层名称(setq aa1 (cdr aa));;判断线条种类(cond((= aa1 "SPLINE");;如果是spline(progn(setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) (setq startPnt1 (vla-get-ControlPoints arcObj))(setq p1(vlax-safearray->list (vlax-variant-value startPnt1)) )(setq x1 (car p1))(setq y1 (cadr p1))(setq z1 (caddr p1))(setq pp1 (list x1 y1 z1))(repeat (- (/ (length p1) 3) 1);;循环，寻找最后一个控制点(setq p1 (cdddr p1))(setq x2 (car p1))(setq y2 (cadr p1))(setq z2 (caddr p1)))(setq pp2 (list x2 y2 z2))))((= aa1 "LWPOLYLINE");;如果是LWPOLYLINE(progn(setq arcObj (VLAX-ENAME->VLA-OBJECT ss)) (setq startPnt1 (vla-get-Coordinates arcObj))(setq p1(vlax-safearray->list (vlax-variant-value startPnt1)) )(setq x1 (car p1))(setq y1 (cadr p1))(setq z1 (caddr p1))(setq pp1 (list x1 y1 z1))(repeat (- (/ (length p1) 3) 1);;循环，寻找最后一个控制点(setq p1 (cdddr p1))(setq x2 (car p1))(setq y2 (cadr p1))(setq z2 (caddr p1)))(setq pp2 (list x2 y2 z2))))(t;;如果是其他种类线条(progn(setq arcObj (VLAX-ENAME->VLA-OBJECT ss))(setq startPnt1 (vla-get-StartPoint arcObj));;获取起点(setq endPnt1 (vla-get-EndPoint arcObj));;获取终点(setq pp1(vlax-safearray->list (vlax-variant-value startPnt1)))(setqpp2 (vlax-safearray->list (vlax-variant-value endPnt1)) ))))(setq x1 (car pp1))(setq y1 (cadr pp1))(setq z1 (caddr pp1))(setq x2 (car pp2))(setq y2 (cadr pp2))(setq z2 (caddr pp2))(setq x (/ (+ x1 x2) 2))(setq y (/ (+ y1 y2) 2))(setq z (/ (+ z1 z2) 2))(setq pt (list x y z));;取得线段两端的中点(setq ang (angle pp1 pp2));;获取角度(if (> (* (/ ang pi) 180) 180) (setq ang (+ ang pi)))(command "text""j""bc"pt""(* (/ ang pi) 180)(strcat "" (rtos dd 2))"")(setq i (1+ i)))(prin1))(prompt "\n <>在图中直接写出长度") (prin1)3.连续打断程序(defun c:br1 ()(command "break" pause "f" pause "@") )4.将CAD文字导入Excel表格(defun c:Q2()(setq ffn (getfiled "写出文件" "" "xls" 1))(princ "\n选取文字...")(setq ss (ssget))(setq ff (open ffn "w"))(setq i 0)(repeat (sslength ss)(setq ssn (ssname ss i))(setq ssdata (entget ssn))(setq sstyp (cdr (assoc 0 ssdata)))(if (or (= sstyp "TEXT") (= sstyp "MTEXT")) (progn(setq txt (cdr (assoc 1 ssdata)))(princ txt ff)(princ "\n" ff)))(setq i (1+ i)))(close ff)(princ (strcat "\n写出文件: " ffn))(prin1))5删除带颜色图元以下程序在别人的贴子里贴过.为了说明问题,今天再贴一次. 改颜色的LISP程序(defun c:c1()(ssget)(command "chprop" "p" "" "c" "1" "") (princ)) (defun c:c2()(ssget)(command "chprop" "p" "" "c" "2" "") (princ)) (defun c:c3()(ssget)(command "chprop" "p" "" "c" "3" "") (princ)) (defun c:c4()(ssget)(command "chprop" "p" "" "c" "4" "") (princ)) (defun c:c5()(ssget)(command "chprop" "p" "" "c" "5" "") (princ)) (defun c:c6()(ssget)(command "chprop" "p" "" "c" "6" "") (princ)) (defun c:c7()(ssget)(command "chprop" "p" "" "c" "7" "") (princ)) (defun c:c8()(ssget)(command "chprop" "p" "" "c" "8" "") (princ))你用C1 命令就可以将图元改为红色了.其余类似.删除红色图元(defun C:D1 (/ m A M)(setq m:err *error* *error* *merr*)(setvar "cmdecho" 0)(command "UNDO" "G")(prompt "选择图形")(setq A (ssget '((62 . 1)) ))(if (/= A nil)(progn(setq M (sslength A))(command "erase" A "")(princ "\n共删除红色图元<")(princ M)(princ ">个") ))(command "UNDO" "E")(princ) )这样,键入 D1 命令,就可以删除红色的图元了.。

CAD_XY坐标标注AUTO_LISP程序

CAD X,Y坐标坐标标注AUTO LISP程序;; (DEFUN IDPT(/ p px py pxx pyy)(DEFUN IDPT ()(SETQ X T)(WHILE X(SETV AR "OSMODE" (+ 1 32 512))(INITGET 1)(SETQ PP (GETPOINT "\nPLEASE PICK THE POINT:")) (SETV AR "OSMODE" 0)(SETQ P (OSNAP PP "INT,END,CEN"))(IF (= P NIL)(PROMPT "\nINV ALID POINT, PICK !")(SETQ X NIL)))(SETQ PXX (CAR P)PYY (CADR P)PX (RTOS PXX 2 PRE1)PY (RTOS PYY 2 PRE1)));;(DEFUN MAX_XY(WI PX PY / L PXPX PYPY) (DEFUN MAX_XY ()(SETQ KKK "X")(SETQ LLL "Y")(SETQ LX (STRLEN PX)L Y (STRLEN PY))(IF (> LX L Y)(PROGN(SETQ W_NU (- LX L Y))(WHILE (> W_NU 0)(SETQ PY (STRCAT " " PY))(SETQ W_NU (- W_NU 1)))))(IF (< LX L Y)(PROGN(SETQ W_NU (- L Y LX))(WHILE (> W_NU 0)(SETQ PX (STRCAT " " PX))(SETQ W_NU (- W_NU 1)))))(SETQ PYPY (STRCAT KKK PY))(SETQ PXPX (STRCAT LLL PX))(SETQ PXL (STRLEN PXPX)PYL (STRLEN PYPY)MAXL (FLOAT (MAX PXL PYL))L (* WI MAXL)));;(DEFUN TEXT_P(/ W WX WY)(DEFUN TEXT_P ()(SETV AR "OSMODE" 0)(INITGET 1)(SETQ W (GETPOINT "\nINPUT X-Y TEXT POSITION:")) (SETQ WX (CAR W))(SETQ WY (CADR W)));;(DEFUN DRLIN(CAL P W L / ALPW WE)(DEFUN DRLIN ()(SETQ AL01 (+ PI CAL))(SETQ ALPW (ANGLE P W))(SETQ AG-D (- ALPW CAL))(IF (> AG-D 0)(PROGN(IF (AND (< AG-D (* PI 0.5)) (> AG-D (* PI 0))) (SETQ WE (POLAR W CAL L)BZ 1))(IF (AND (> AG-D (* PI 0.5)) (< AG-D (* PI 1.5))) (SETQ WE (POLAR W AL01 L)BZ 2))(IF (AND (> AG-D (* PI 1.5)) (< AG-D (* PI 2))) (SETQ WE (POLAR W CAL L)BZ 3));>>>>>)(PROGN;<<<<<(IF (AND (> AG-D (* PI -0.5)) (< AG-D (* PI 0))) (SETQ WE (POLAR W CAL L)BZ 1))(IF (AND (< AG-D (* PI -0.5)) (> AG-D (* PI -1.5))) (SETQ WE (POLAR W AL01 L)BZ 2))(IF (AND (< AG-D (* PI 1.5)) (> AG-D (* PI -2))) (SETQ WE (POLAR W CAL L)BZ 3));>>>>>))(COMMAND "PLINE" P "W" 0.0 "" W WE ""));;(DEFUN DRCORD(AL01 ALPW H CAL PXPX PYPY /)(DEFUN DRCORD ()(IF (= BZ 2)(SETQ WB WE)(SETQ WB W))(SETQ WBX (POLAR WB (+ (* PI 0.5) CAL) H)WBY (POLAR WB (+ (* PI 1.5) CAL) H))(SETQ AL_CAL (* 180 (/ CAL PI)))(COMMAND "TEXT" "J" "ML" WBX H AL_CAL PYPY) (COMMAND "TEXT" "J" "ML" WBY H AL_CAL PXPX));;(DEFUN DRELEV(AL01 ALPW WE CAL WI PRE2)(DEFUN DRELEV ()(IF (< WX PXX)(SETQ EPL (POLAR WE AL01 (* WI 0.5)))(SETQ EPR (POLAR WE CAL (* WI 0.5))))(SETQ DHH (GETREAL "\nINPUT DESIGN ELEV A TION:"))(IF (= DHH NIL)(PROMPT "\nNO ELEV ATION A V AILABLE NOW!")(PROGN(SETQ DH (RTOS DHH 2 PRE2))(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "ELEV")(ELA))(IF (< WX PXX)(COMMAND "TEXT" "J" "MR" EPL H AL_CAL DH)(COMMAND "TEXT" "J" "ML" EPR H AL_CAL DH)))))(DEFUN PCR ()(SETQ TS 0.0)(SETV AR "OSMODE" 33)(SETQ X T)(WHILE X(INITGET 1)(SETQ PP1 (GETPOINT "\nENTER THE FIRST POINT:"))(SETQ P1 (OSNAP PP1 "INT,END"))(IF (/= P1 NIL)(SETQ X NIL)(PROGN (PROMPT "\nNO INT OR END FOUND, CONTINUE? [Y/N]") (INITGET 1)(SETQ J (GETSTRING))(IF (OR (= J "Y") (= J "y"))(PROGN (SETQ P1 PP1) (SETQ X NIL))(PROMPT "\nRESELECT PLEASE!")))))(SETQ OP1 P1)(SETQ P_NUMBER 1)(SETQ X T)(WHILE X(SETQ P_NUMBER (+ 1 P_NUMBER))(SETQ PRO_1 (STRCAT "\n THE <" (ITOA P_NUMBER)))(SETQ PRO_1 (STRCAT PRO_1 "> POINT(ENTER=END SELECT:)"))(SETQ P2 (GETPOINT PRO_1))(IF (/= P2 NIL)(PROGN (SETQ SS(* (+ (CADR P1) (CADR P2)) (- (CAR P2) (CAR P1)) 0.5) )(SETQ TS (+ TS SS))(SETQ P1 P2))(PROGN (SETQ SS(* (+ (CADR OP1) (CADR P1)) (- (CAR OP1) (CAR P1)) 0.5) )(SETQ TS (+ TS SS))(SETQ X NIL))))(SETQ S0 (ABS TS))(SETQ TSS (RTOS S0 2 PRE3))(SETV AR "OSMODE" 0)(INITGET 1)(SETQ W (GETPOINT "\nINPUT TEXT POSITION:"))(COMMAND "TEXT" W H 0.0 (STRCAT "S=" TSS)))(DEFUN ETP ()(SETQ X T)(WHILE X(PROMPT "\nSELECT EDGE OF THE POL YGON:")(SETQ S_SET (SSGET))(IF (= S_SET NIL)(PROMPT "\nINV ALID SELECTION, RESELECT PLEASE!")(SETQ X NIL)))(CA_AREA))(DEFUN LTP ()(INITGET 1)(SETQ URC (GETCORNER(SETQ DLC (GETPOINT "\nENTER FIRST CORNER:"))"\nTHE SECOND CORNER:"))(SETQ SSET (SSGET "W" DLC URC))(COND((OR (= ENTP "LINE") (= ENTP "ARC"))(COMMAND "PEDIT" (SSGET P10) "Y" "J" SSET "" "X"))((= ENTP "POL YLINE")(COMMAND "PEDIT" (SSGET P10) "J" SSET "" "X"))(T (PROMPT "\nINV ALID ENTITY FOR PEDIT!"))))(DEFUN RETP ()(SETQ SET1 (SSGET P10))(SETQ ENAME (SSNAME SET1 0))(SETQ ELIST (ENTGET ENAME))(SETQ ENTP (CDR (ASSOC 0 ELIST))))(DEFUN PLTP ()(SETQ ENTP2 (CDR (ASSOC 70 ELIST))))(DEFUN PLS ()(PLTP)(IF (= ENTP2 1)(PROGN (REDRAW ENAME 3)(PROMPT "\nIT'S A CLOSED POL YLINE")(S))(PROGN(REDRAW ENAME 3)(PROMPT "\nIT'S NOT A CLOSED PLINE, TRY TO CLOSE IT!")(LTP)(RETP)(PLTP)(IF (= ENTP2 1)(PROGN (PROMPT "\nNOW IT HAS BEEN CLOSED!")(S))(PROGN (REDRAW ENAME 3)(SETQ X(GETSTRING(STRCAT"\nCAN'T BE CLOSED AUTOMA TICALL Y, CALCULATE IST AREA?""\n<'Y' FOR YES AND ANY OTHER KEY FOR NO>")))(IF (OR (= X "Y") (= X "y"))(S)(PROMPT "\nTHIS ONE IGNORED, CALCULATE NEXT POL YGON!")))))))(DEFUN S ()(COMMAND "AREA" "E" (SSGET P10))(SETQ SS (GETV AR "AREA"))(SETQ S1 (RTOS SS 2 PRE3))(SETV AR "OSMODE" 0)(INITGET 1)(SETQ PT (GETPOINT "\nINPUT TEXT POSITION:"))(COMMAND "TEXT" PT H 0.0 (STRCAT "S=" S1)))(DEFUN THN ()(IF (/= B0 NIL)(PROGN(SETQ BI (RTOS B0 2 1))(INITGET 6)(SETQB (GETREAL(STRCAT "\nINPUT MAP SCALE FACTOR [1:X*1000]/<" BI ">")))(IF (= B NIL)(SETQ B B0)(SETQ B0 B)))(PROGN(INITGET 7)(SETQ B (GETREAL "\nINPUT MAP SCALE FACTOR [1:X*1000]"))(SETQ B0 B)))(IF (/= CAL0 NIL)(PROGN(SETQ CAL1 (RTOS CAL0 2 1))(INITGET 8)(SETQ CAL2 (GETREAL(STRCAT "\nINPUT TEXT ROTATE ANGLE[d]/<" CAL1 ">")))(IF (= CAL2 NIL)(SETQ CAL (/ (* PI CAL0) 180))(PROGN(SETQ CAL (/ (* PI CAL2) 180))(SETQ CAL0 CAL2))))(PROGN (INITGET 8)(SETQ CAL2 (GETREAL "\nINPUT TEXT ROTATE ANGLE[d]:"))(SETQ CAL (/ (* PI CAL2) 180))(SETQ CAL0 CAL2)))(IF (/= HH0 NIL)(PROGN(SETQ HHI (RTOS HH0 2 1))(INITGET 6)(SETQ HH (GETREAL(STRCAT "\nINPUT TEXT HEIGHT [mm]/<" HHI ">")))(IF (= HH NIL)(SETQ HH HH0)(SETQ HH0 HH)))(PROGN (INITGET 7)(SETQ HH (GETREAL "\nINPUT TEXT HEIGHT [MM]:"))(SETQ HH0 HH)))(SETQ H (* HH B))(IF (= WF NIL)(SETQ WF 1.0))(SETQ WI (* H WF)))(DEFUN PRE1N ()(IF (/= PRE10 NIL)(PROGN (SETQ PRE1I (RTOS PRE10 2 0))(INITGET 4)(SETQPRE1 (GETINT(STRCA T "\nINPUT DECIMAL PLACE FOR X-Y COORDINATE <"PRE1I">:")))(IF (= PRE1 NIL)(SETQ PRE1 PRE10)(SETQ PRE10 PRE1)))(PROGN (INITGET 5)(SETQ PRE1(GETINT "\nINPUT DECIMAL PLACE FOR X-Y COORDINATE:") )(SETQ PRE10 PRE1))))(DEFUN PRE2N ()(IF (/= PRE20 NIL)(PROGN (SETQ PRE2I (RTOS PRE20 2 0))(INITGET 4)(SETQ PRE2 (GETINT(STRCAT "\nINPUT DECIMAL PLACE FOR ELEV ATION <"PRE2I">:")))(IF (= PRE2 NIL)(SETQ PRE2 PRE20)(SETQ PRE20 PRE2)))(PROGN (INITGET 5)(SETQ PRE2(GETINT "\nINPUT DECIMAL PLACE FOR ELEV A TION:"))(SETQ PRE20 PRE2))))(DEFUN PRE3N ()(IF (/= PRE30 NIL)(PROGN (SETQ PRE3I (RTOS PRE30 2 0))(INITGET 4)(SETQ PRE3(GETINT(STRCA T "\nINPUT DECIMAL PLACE FOR AREA IDENTIFICATION <"PRE3I">:")))(IF (= PRE3 NIL)(SETQ PRE3 PRE30)(SETQ PRE30 PRE3)))(PROGN (INITGET 5)(SETQ PRE3(GETINT "\nINPUT DECIMAL PLACE FOR AREA IDENTIFICATION:") )(SETQ PRE30 PRE3))))(DEFUN XYZ ()(THN)(PRE1N)(PRE2N)(SETQ XX T)(WHILE XX(INITGET "Exit Continue")(SETQ ZZ (GETKWORD "\nExit/Continue?/<Continue>"))(COND((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC))((OR (= ZZ NIL) (= ZZ "Continue"))(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "CORD")(XYLA))(IDPT);;(TEXT_P);; (MAX_XY WI PX PY L)(MAX_XY);; (DRLIN CAL P W L)(DRLIN);; (DRCORD AL01 ALPW H CAL PXPX PYPY)(DRCORD);; (DRELEV AL01 ALPW WE CAL WI PRE2)(DRELEV)))))(DEFUN FIX ()(THN)(PRE1N)(PRE2N)(SETQ XX2 T)(WHILE XX2(SETQ XX3 NIL)(IDPT)(ALN1)(SETQ XX T)(WHILE XX(INITGET "Help Exit COntinue CHangepar")(SETQ ZZ (GETKWORD "\nHelp/Exit/COntinue/CHangepar?/<COntinue>"))(COND((= ZZ "Help")(TEXTPAGE)(PROMPT"\n ENTER A V ALUE OR A POINT TO DEFINE THE LENGTH OF OBLIQUAL BASELINE AND")(PROMPT"\nENTER A POINT IN ONE OF THE FOUR QAUDRANTS TO SELECT THE DIRECTION OF THE ")(PROMPT"\nOBLIQUAL BASELINE OR PRESS 'ENTER' TO SELECT THE DEFAULT V ALUES."))((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NILXX2 NIL)(PRINC))((OR (= ZZ NIL) (= ZZ "Continue"))(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "CORD")(XYLA))(IF (= XX3 T)(IDPT))(SETQ XX3 T)(CPXY)(ALN2)(TBL)(CORD)(DE))((= ZZ "CHangepar") (SETQ XX NIL))))))(DEFUN AE ()(ELA)(THN)(PRE2N)(SETQ XX T)(WHILE XX(INITGET "Help Exit Continue")(SETQ ZZ (GETKWORD "\nHelp/Exit/Continue?/<Continue>"))((= ZZ "Help")(TEXTPAGE)(PROMPT"\n FIRST SELECT THE ID POINT, THEN SELECT THE END OF THE")(PROMPT "\nHORIZONTAL BASELINE;"))((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC))((OR (= ZZ NIL) (= ZZ "Continue"))(SETV AR "OSMODE" 1)(SETQ PP (GETPOINT "\nSELECT THE ID POINT:"))(SETQ P (OSNAP PP "END"))(SETQ PXX (CAR P))(SETQ X T)(WHILE X(SETQ WEE (GETPOINT "\nINPUT THE TEXT POSITION:"))(SETQ WE (OSNAP WEE "END"))(IF (= WE NIL)(PROMPT "\nINV ALID POSITION, RESELECT PLEASE!")(SETQ X NIL)))(SETQ WX (CAR WE))(SETV AR "OSMODE" 0)(DE)))))(DEFUN PLGS ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA))(THN)(PRE3N)(ETP)(SETV AR "osmode" 0)(SETQ PT (GETPOINT "\n Please input TEXT POSITION:")) (COMMAND "text"PTH0.0(STRCAT "S=" S_AREA)))(DEFUN CA_AREA ()(SETQ ENT_NAME (SSNAME S_SET 0))(SETQ ENT_NUM (SSLENGTH S_SET))(SETQ T_AREA 0LOOP 0NUM 0)(WHILE LOOP(COMMAND "AREA" "E" ENT_NAME)(SETQ S1_AREA (LIST (GETV AR "AREA")))(SETQ S2_AREA (CAR S1_AREA))(SETQ T_AREA (+ T_AREA S2_AREA))(SETQ NUM (+ NUM 1))(SETQ ENT_NAME (SSNAME S_SET NUM))(IF (= NUM ENT_NUM)(SETQ LOOP NIL)))(SETQ S_AREA (RTOS T_AREA 2 PRE3)))(DEFUN E_LAYER ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA))(THN)(PRE3N)(SETQ L_NAME (GETSTRING "\nPlaese input LAYER NAME:")) (SETQ S_SET (SSGET "X"(LIST (CONS 0 "POL YLINE")(CONS 8 L_NAME))))(CA_AREA)(SETV AR "osmode" 0)(INITGET 1)(SETQ PT (GETPOINT "\n Please input TEXT POSITION:")) (COMMAND "text"PTH0.0(STRCAT "The layer<" L_NAME ">S=" S_AREA)))(DEFUN E_COLOR ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA))(THN)(PRE3N)(SETQ C_NAME (GETINT "\nPlaese input COLOR NAME:")) (SETQ S_SET (SSGET "X"(LIST (CONS 0 "POL YLINE")(CONS 62 C_NAME))))(CA_AREA)(SETV AR "osmode" 0)(INITGET 1)(SETQ PT (GETPOINT "\n Please input TEXT POSITION:")) (COMMAND "text"PTH0.0(STRCAT "The color <" (RTOS C_NAME 2 0) ">S=" S_AREA) ))(DEFUN POS ()(SETQ CLA (GETV AR "CLAYER"))(IF (/= CLA "AREA")(SLA))(THN)(PRE3N)(SETQ XX T)(WHILE XX(INITGET "Help Exit Continue")(SETQ ZZ (GETKWORD "\nHelp/Exit/Continue?/<Continue>"))(COND((= ZZ "Help")(TEXTPAGE)(PROMPT"\n ENTER THE POINTS TO DEFINE THE EDGE OF THE REGION")(PROMPT"\nTO BE CALCULATED AND IDed, AFTER LAST POINT ENTERED,")(PROMPT"\nPRESS 'ENTER' AND THEN SELECT A POINT TO DEFINE THE")(PROMPT "\nPOSITION OF THE AREA ID TEXT."))((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC))((OR (= ZZ NIL) (= ZZ "Continue"))(PCR)))))(DEFUN XYLA ()(COMMAND "LAYER" "M" "CORD" "C" "CYAN" "" ""))(DEFUN ELA ()(COMMAND "LAYER" "M" "ELEV" "C" "CYAN" "" ""))(DEFUN SLA ()(COMMAND "LAYER" "M" "AREA" "C" "CYAN" "" ""))(DEFUN ALN1 ()(IF (/= AL0 NIL)(PROGN (SETQ ALI (RTOS AL0 2 1))(INITGET 70)(PROMPT(STRCAT "\nINPUT OBLIQUAL LINE LENGTH [DRAWING UNIT]/<"ALI">:"))(SETQ ALL (GETDIST P))(IF (= ALL NIL)(SETQ ALL AL0)(SETQ AL0 ALL)))(PROGN (INITGET 71)(SETQ ALL (GETDIST P"\nINPUT OBLIQUAL LINE LENGTH [DRAWING UNIT]"))(SETQ AL0 ALL)))(IF (/= WA0 NIL)(PROGN(SETQ WAI (ANGTOS W A0 0 0))(PROMPT(STRCAT "\nCHOOSE THE DIRECTION OF THE OBLIQUAL LINE<"WAI"d>:"))(SETQ DRL (GETANGLE P))(IF (= DRL NIL)(SETQ W A WA0)(PROGN(COND((< DRL (* PI 0.5))(SETQ W A (* PI 0.25)))((< DRL PI)(SETQ W A (* PI 0.75)))((< DRL (* PI 1.5))(SETQ W A (* PI 1.25)))((< DRL (* PI 2.0))(SETQ W A (* PI 1.75)))))))(PROGN (INITGET 1)(SETQDRL (GETANGLE P"\nCHOOSE THE DIRECTION OF THE OBLIQUAL LINE:"))(COND((< DRL (* PI 0.5))(SETQ WA (* PI 0.25)))((< DRL PI)(SETQ WA (* PI 0.75)))((< DRL (* PI 1.5))(SETQ WA (* PI 1.25)))((< DRL (* PI 2.0))(SETQ WA (* PI 1.75))))(SETQ WA0 WA))))(DEFUN ALN2 ()(SETQ W (POLAR P (+ CAL WA) ALL))(SETQ WX (CAR W)))(DEFUN TSET ()(SETV AR "FILEDIA" 0)(SETQ WFF (GETREAL"\nINPUT THE WIDTH-HEIGHT FACTOR OF TEXT<1.0>:"))(IF (= WFF NIL)(SETQ WF 1.0))(COMMAND "STYLE" "STANDARD" "MONOTXT" "0.0" WF "0" "N" "N" "N") (SETV AR "FILEDIA" 1)(COMMAND "COLOR" "BYLAYER")(PRINC))(DEFUN CO-ZOOM ()(PROMPT "\nTURN OFF ALL UNCONCERN LAYERS!")(IF (/= CS0 NIL)(PROGN (SETQ CSI (RTOS CS0 2 1))(INITGET 6)(PROMPT (STRCAT "\nINPUT CURRENT SCALE FACTOR<" CSI ">:"))(SETQ CS (GETREAL))(IF (= CS NIL)(SETQ CS CS0)(SETQ CS0 CS)))(PROGN (SETQ CS (GETREAL "\nINPUT CURRENT SCALE FACTOR:")) (SETQ CS0 CS)))(IF (/= DS0 NIL)(PROGN (SETQ DSI (RTOS DS0 2 1))(INITGET 6)(PROMPT (STRCAT "\nINPUT PREFER SCALE FACTOR<" DSI ">:"))(SETQ DS (GETREAL))(IF (= DS NIL)(SETQ DS DS0)(SETQ DS0 DS)))(PROGN (SETQ DS (GETREAL "\nINPUT PREFER SCALE FACTOR:")) (SETQ DS0 DS)))(SETQ FTOR (/ DS CS))(SETQ XX T)(WHILE XX(INITGET "Help Exit Continue")(SETQ ZZ (GETKWORD "\nHelp/Exit/Continue?/<Continue>"))(COND((= ZZ "Help")(TEXTPAGE))((= ZZ "Exit")(PROMPT "\nEXIT TO MAIN SELECTIONS")(SETQ XX NIL)(PRINC))((OR (= ZZ NIL) (= ZZ "Continue"))(SETV AR "OSMODE" 32)(INITGET 1)(SETQ P (GETPOINT "\SELECT THE ID BASELINE:"))(SETQ PP (OSNAP P "END,INS"))(SETQ P2 (GETCORNER(SETQ P1 (GETPOINT "\nSELECT TEXTs IN WINDOW:"))))(SETQ SSET (SSGET "W" P1 P2))(COMMAND "SCALE" SSET "" PP FTOR)))))(DEFUN HLP ()(PROMPT "\n"))(defun-q *error* () ("PROGRAM TERMINA TED BY USER")(PRINC "\nERROR: ")(PRINC "PROGRAM TERMINA TED BY USER!")(PRINC))(DEFUN C:DM ()(PRINC)(SETQ CULA (GETV AR "CLAYER"))(SETQ XXX T)(SETQ ZP "3d")(WHILE XXX(INITGET"Help Set 3D F3d Ae APOint APLine ALayer AColor Coz Exit")(SETQZ (GETKWORD"\nHelp/Set/3D/F3d/Ae/APOint/APLine/ALayer/AColor/Coz/Exit:"))(SETQ ZP1 Z)(IF (= Z NIL)(SETQ Z ZP))(SETQ ZP ZP1)(COND((= Z "Help") (HLP))((= Z "Set") (TSET))((= Z "3D") (XYZ))((= Z "F3d") (FIX))((= Z "APOint") (POS))((= Z "APLine") (PLGS))((= Z "ALayer") (E_LAYER))((= Z "AColor") (E_COLOR))((= Z "Coz") (CO-ZOOM))((= Z "Ae") (AE))((= Z "Exit")(COMMAND "LAYER" "S" CULA "")(PROMPT "\n *** Exit from DM program, Thanks! ***")(SETQ XXX NIL))))(PRINC))。