CAD LISP 程序备课讲稿.docx
《CAD LISP 程序备课讲稿.docx》由会员分享，可在线阅读，更多相关《CAD LISP 程序备课讲稿.docx（7页珍藏版）》请在冰豆网上搜索。
CADLISP程序备课讲稿
CADLISP程序
1.计算所有线段总长度（加载后只需框选所有线段便可得出这些线段的总长度）
（defunc:
LL（）
（setvar"cmdecho"1）
（setqen（ssget（list'（0."spline,arc,line,ellipse,LWPOLYLINE"））））
（setqi0）
（setqll0）
（repeat（sslengthen）
（setqss（ssnameeni））
（setqendata（entgetss））
（command"lengthen"ss""）
（setqdd（getvar"perimeter"））
（setqll（+ddll））
（setqi（1+i））
）
（princ"所选线条总长为：
"）（princll）（princ）
）
2.标注所有线段（加载后只需框选所有线段便可得标注这些线段）
（defunc:
LLL（）
（COMMAND"UCS"""）
（setvar"cmdecho"1）
（SETVAR"OSMODE"0）
（setq AcadObject （vlax-get-acad-object）
AcadDocument（vla-get-ActiveDocumentAcadobject）
mSpace （vla-get-ModelSpaceAcaddocument）
）
;;选取需要测量的样条曲线、圆弧、直线、椭圆
（setqen（ssget（list'（0."spline,arc,line,ellipse,LWPOLYLINE"））））
（setqi0）
;;获取系统参数textsize
（setqshh（getvar"textsize"））
（setqstr_hh（strcat"\n文字高度<"（rtosshh2）">:
"））
（setqhh（getdiststr_hh））
（whilehh
（setvar"textsize"hh）
（setqhhnil））
;;输入标注文字高度
;;循环开始
（repeat（sslengthen）
（setqss（ssnameeni））
（setqendata（entgetss））
（command"lengthen"ss""）
（setqdd（getvar"perimeter"））
（princ（strcat"\n长度="（rtosdd2）））
;;寻找代表图层的字符串
（setqaa（assoc0endata））
;;获取图层名称
（setqaa1（cdraa））
;;判断线条种类
（cond
（（=aa1"SPLINE"）
;;如果是spline
（progn
（setqarcObj（VLAX-ENAME->VLA-OBJECTss））
（setqstartPnt1（vla-get-ControlPointsarcObj））
（setqp1
（vlax-safearray->list（vlax-variant-valuestartPnt1））
）
（setqx1（carp1））
（setqy1（cadrp1））
（setqz1（caddrp1））
（setqpp1（listx1y1z1））
（repeat（-（/（lengthp1）3）1）
;;循环，寻找最后一个控制点
（setqp1（cdddrp1））
（setqx2（carp1））
（setqy2（cadrp1））
（setqz2（caddrp1））
）
（setqpp2（listx2y2z2））
）
）
（（=aa1"LWPOLYLINE"）
;;如果是LWPOLYLINE
（progn
（setqarcObj（VLAX-ENAME->VLA-OBJECTss））
（setqstartPnt1（vla-get-CoordinatesarcObj））
（setqp1
（vlax-safearray->list（vlax-variant-valuestartPnt1））
）
（setqx1（carp1））
（setqy1（cadrp1））
（setqz1（caddrp1））
（setqpp1（listx1y1z1））
（repeat（-（/（lengthp1）3）1）
;;循环，寻找最后一个控制点
（setqp1（cdddrp1））
（setqx2（carp1））
（setqy2（cadrp1））
（setqz2（caddrp1））
）
（setqpp2（listx2y2z2））
）
）
（t
;;如果是其他种类线条
（progn
（setqarcObj（VLAX-ENAME->VLA-OBJECTss））
（setqstartPnt1（vla-get-StartPointarcObj））
;;获取起点
（setqendPnt1（vla-get-EndPointarcObj））
;;获取终点
（setqpp1
（vlax-safearray->list（vlax-variant-valuestartPnt1））
）
（setq
pp2（vlax-safearray->list（vlax-variant-valueendPnt1））
）
）
）
）
（setqx1（carpp1））
（setqy1（cadrpp1））
（setqz1（caddrpp1））
（setqx2（carpp2））
（setqy2（cadrpp2））
（setqz2（caddrpp2））
（setqx（/（+x1x2）2））
（setqy（/（+y1y2）2））
（setqz（/（+z1z2）2））
（setqpt（listxyz））
;;取得线段两端的中点
（setqang（anglepp1pp2））
;;获取角度
（if （>（*（/angpi）180）180）
（setqang（+angpi））
）
（command"text"
"j"
"bc"
pt
""
（*（/angpi）180）
（strcat""（rtosdd2））
""
）
（setqi（1+i））
）
（prin1）
）
（prompt"\n<>在图中直接写出长度"）
（prin1）
3.连续打断程序
（defunc:
br1（）
（command"break"pause"f"pause"@"）
）
4.将CAD文字导入Excel表格
（defunc:
Q2（）
（setqffn（getfiled"写出文件""""xls"1））
（princ"\n选取文字..."）
（setqss（ssget））
（setqff（openffn"w"））
（setqi0）
（repeat（sslengthss）
（setqssn（ssnamessi））
（setqssdata（entgetssn））
（setqsstyp（cdr（assoc0ssdata）））
（if（or（=sstyp"TEXT"）（=sstyp"MTEXT"））
（progn
（setqtxt（cdr（assoc1ssdata）））
（princtxtff）
（princ"\n"ff）
）
）
（setqi（1+i））
）
（closeff）
（princ（strcat"\n写出文件:
"ffn））
（prin1）
）
5删除带颜色图元
以下程序在别人的贴子里贴过.为了说明问题,今天再贴一次.
改颜色的LISP程序
（defunc:
c1（）（ssget）（command"chprop""p""""c""1"""）（princ））
（defunc:
c2（）（ssget）（command"chprop""p""""c""2"""）（princ））
（defunc:
c3（）（ssget）（command"chprop""p""""c""3"""）（princ））
（defunc:
c4（）（ssget）（command"chprop""p""""c""4"""）（princ））
（defunc:
c5（）（ssget）（command"chprop""p""""c""5"""）（princ））
（defunc:
c6（）（ssget）（command"chprop""p""""c""6"""）（princ））
（defunc:
c7（）（ssget）（command"chprop""p""""c""7"""）（princ））
（defunc:
c8（）（ssget）（command"chprop""p""""c""8"""）（princ））
你用C1命令就可以将图元改为红色了.其余类似.
删除红色图元
（defunC:
D1（/mAM）
（setqm:
err*error**error**merr*）
（setvar"cmdecho"0）
（command"UNDO""G"）
（prompt"选择图形"）
（setqA（ssget'（（62.1））））
（if（/=Anil）（progn
（setqM（sslengthA））
（command"erase"A""）
（princ"\n共删除红色图元<"）（princM）（princ">个"）
））
（command"UNDO""E"）
（princ） ）
这样,键入D1命令,就可以删除红色的图元了.
升级会员 