加载中…
个人资料
万研专利
万研专利
  • 博客等级:
  • 博客积分:0
  • 博客访问:120
  • 关注人气:63
  • 获赠金笔:0支
  • 赠出金笔:0支
  • 荣誉徽章:
正文 字体大小:

测量作图常用lisp程序(2)   AutoCAD  自己编写(江西理工大学 王军锋&n

(2014-10-09 09:57:10)
分类: 测量


 
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;等间距标注带高程的二维多段线高程程序 1.0;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                                     ;;
;;   1、本程序的功能为:等间距标注带高程的二维多段线高程。                              ;;
;;                                                                                     ;;
;;   2、程序主命令为"bz",在命令行中输入"bz"按提示使用即可。                            ;;
;;                                                                                     ;;
;;   3、程序要求必须全部为带高程的二维多段线,否则程序会出错!!!。                      ;;
;;                                                                                     ;;
;;   4、用户使用此程序前请做好备份!                                                    ;;
;;                                                                                     ;;
;;   5、可以通过替换  标注的高程文字   来把高程文字放到你想建立的图层名称中去。        ;;
;;                                                                                     ;;
;;                                                                      2011.8.10      ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
;
  (vl-load-com);载入com,以使本程序可以使用VLisp函数
  (setq AcadObject (vlax-get-acad-object))
  (setq AcadDocument (vla-get-ActiveDocument Acadobject))
  (setq mSpace (vla-get-ModelSpace Acaddocument))
;
;
(defun c:bz()                                                    ;程序名为bz,把带高程的二维多段线沿一定距离标注高程,
                                          ;
  (prompt "\n <<请框选带高程的二维多段线:>>")
  (setq ss (ssget '((0 . "POLYLINE"))))                          ;取得选择集。
              (setq d (getreal "指定标注文字之间的间距[80]:"))
              (if d
                  (setq d d)                                     ;把文字间的间距赋值给d,如果无输入则执行下一行赋值程序。
                  (setq d 80.0)                                  ;把文字间的默认间距赋值给d.
              )
              (setq textheight_1 (getreal "指定标注文字的高度[2]:"))
              (if textheight_1
                  (setq textheight_1 textheight_1)               ;把文字的高度赋值给textheight_1,如果无输入则执行下一行赋值程序。
                  (setq textheight_1 2)                          ;把文字的默认高度赋值给textheight_1.
              )
  (setq n 0 k 0)              ;选择集的起始值n=0,完成更改的多段线数k=0。
  (repeat (sslength ss)       ;计算选择集的对象个数。
    (setq en (ssname ss n))   ;依据索引值取出选择集中的图元名。
          (dimtext en)        ;调用标注高程文字的子函数,此函数为执行函数。
          (setq k (1+ k))     ;完成标注高程的线数,完成一个加一。
          (setq n (1+ n))     ;
  )
 (princ (strcat "\n 共完成< " (itoa k) " >条二维多段线的高程标注." ))
 (princ "\n快速更改三维多段线为二维多段线.")
 (prin1)
)
;
;
;
;
  (defun dimtext (ename)                                               ;考虑完全的标注高程文字的子函数。
      (setq obj (vlax-ename->vla-object ename))                        ;把ename转换为vlax对象。 
      (setq varnil1 (vlax-make-variant -1  11))                        ;新建立一个vlax下的布尔型变量,11表示布尔型变量,-1表示为真。
         (if (= (vlax-variant-value varnil1)  (vla-get-closed obj))    ;如果原来obj三维多段线是闭合的,则执行下面一句,目的是为了对圆形多段线标注。
             (progn
                   (vla-put-closed obj 0)                              ;使二维多段线先不闭合。             
                   (dimtext_exe obj)                                   ;调子函数。
                   (vla-put-closed obj -1)                             ;使二维多段线再闭合。
             )
             (progn
                   (dimtext_exe obj)                                   ;调子函数。
             )
         )
     
 
 
     (defun dimtext_exe (ename)                                       ;标注高程文字的子函数。
              (setq endpoint (vlax-curve-getEndPoint ename))          ;得出选中线段的终点。
              (setq l (vlax-curve-getDistAtPoint ename endpoint))     ;得出选中线段的长度。
              (setq dis 0)                                            ;设置距离dis为0.  
              (setq layerSel (vla-get-Layers AcadDocument))           ;和下一行一起建立一个新的图层。
              (setq layerObj (vla-add layerSel "标注的高程文字"))     ;图层名称为:  "标注的高程文字"
              (vla-put-Color layerObj acGreen)                        ;图层颜色为:   绿色              
                (while (<= dis (- l d))                               ;当文字间的间距小于线段的长度时。
                    (progn ;;progn1        
                          (setq dis (+ dis d))
                          (setq point1_spx (vlax-curve-getPointAtDist ename dis))                                   ;取得多段线位于坡顶的端点point1_spx
                          (setq firstDriv (vlax-curve-getFirstDeriv ename (vlax-curve-getParamAtDist ename dis)))     ;取得point1_spx处曲线的切向矢量
                          (setq
                                   deriv_x  (car firstDriv)           ;此处切向量的x坐标值
                                   deriv_y  (cadr firstDriv)          ;此处切向量的y坐标值
                          )
                          (setq  deriv_l (sqrt (+ (* deriv_x deriv_x) (* deriv_y deriv_y))))      ;切向量的长度,x^2+y^2再开根号
                          (setq
                                point2_x1 (/ deriv_x deriv_l)         ;切向量的cosa值
                                point2_y1 (/ deriv_y deriv_l)         ;切向量的sina值
                          )
                          (setq
                                   point1_x  (car point1_spx)         ;点1的x值              
                                   point1_y  (cadr point1_spx)        ;点1的y值      
                          )
                         (setq
                                   point2_x  (+ point1_x (* point2_x1 d))      ;点2的x值,由;点1的x值加上  要画的线段长度*cosa   ,从而保证相切处旋转后和已有线段垂直。
                                   point2_y  (+ point1_y (* point2_y1 d))      ;点2的y值,由;点1的y值加上  要画的线段长度*sina   ,从而保证相切处旋转后和已有线段垂直。
                          )
                                (setq pts (vlax-variant-value (vla-get-coordinates obj)))                      ;把三维多段线的全部三维点坐标赋值给pts。
                                (setq gaocheng (vla-get-elevation obj))                                        ;从pts中提取出Z值,即多段线的高程值。
                                (setq insertpoint (list point1_x point1_y gaocheng))                           ;取点文字的插入点处的三维坐标值,并赋值给insertpoint。
                                (setq rotate_angle  (angle(list point1_x point1_y) (list point2_x point2_y)))  ;求出插入点处文字应该旋转的角度。   
                                (setq insertpoint2 (vlax-make-safearray vlax-vbDouble '(0 . 2)))               ;建立安全数组变量。
                                (vlax-safearray-fill insertpoint2 insertpoint)                                 ;把插入点坐标值赋给安全数组变量insertpoint2。
                                (setq textobj (vla-AddText mSpace gaocheng insertpoint2 textheight_1))         ;创建文本对象,需要给三个参数:文字需要显示的高程值字符串 插入点坐标 文字高度。
                                (vla-put-Rotation textobj rotate_angle)                                        ;把文字应该旋转的角度赋值给此文字。
                                (vla-put-Alignment textobj 10)                                                 ;设置文字的对齐方式为正中,参数10为正中的意思。
                                (vla-put-Layer textobj "标注的高程文字")                                       ;把文字存储到新建立的图层。
                                (vla-put-TextAlignmentPoint textobj insertpoint2)                              ;设置文字对齐处的插入点,此行代码和上面的代码有先后顺序的区别。
                    );;progn1
                );;while
;;;--------------------------------------------------------------------------------------------------------------------------------------------------------------------------------
              (setq dis 0)                                            ;设置距离dis为0.
                (if  (> dis (- l d))   ;;if1
                     (progn ;;progn2
                       (setq minus_d (/ l 2))
                              (setq dis (+ dis minus_d))
                              (setq point1_spx (vlax-curve-getPointAtDist ename dis))                                   ;取得多段线位于坡顶的端点point1_spx
                          (setq firstDriv (vlax-curve-getFirstDeriv ename (vlax-curve-getParamAtDist ename dis)))     ;取得point1_spx处曲线的切向矢量
                          (setq
                                   deriv_x  (car firstDriv)           ;此处切向量的x坐标值
                                   deriv_y  (cadr firstDriv)          ;此处切向量的y坐标值
                          )
                          (setq  deriv_l (sqrt (+ (* deriv_x deriv_x) (* deriv_y deriv_y))))      ;切向量的长度,x^2+y^2再开根号
                          (setq
                                point2_x1 (/ deriv_x deriv_l)         ;切向量的cosa值
                                point2_y1 (/ deriv_y deriv_l)         ;切向量的sina值
                          )
                          (setq
                                   point1_x  (car point1_spx)         ;点1的x值              
                                   point1_y  (cadr point1_spx)        ;点1的y值      
                          )
                         (setq
                                   point2_x  (+ point1_x (* point2_x1 minus_d))      ;点2的x值,由;点1的x值加上  要画的线段长度*cosa   ,从而保证相切处旋转后和已有线段垂直。
                                   point2_y  (+ point1_y (* point2_y1 minus_d))      ;点2的y值,由;点1的y值加上  要画的线段长度*sina   ,从而保证相切处旋转后和已有线段垂直。
                          )
                                (setq pts (vlax-variant-value (vla-get-coordinates obj)))                      ;把三维多段线的全部三维点坐标赋值给pts。
                                (setq gaocheng (vla-get-elevation obj))                                        ;从pts中提取出Z值,即多段线的高程值。
                                (setq insertpoint (list point1_x point1_y gaocheng))                           ;取点文字的插入点处的三维坐标值,并赋值给insertpoint。
                                (setq rotate_angle  (angle(list point1_x point1_y) (list point2_x point2_y)))  ;求出插入点处文字应该旋转的角度。   
                                (setq insertpoint2 (vlax-make-safearray vlax-vbDouble '(0 . 2)))               ;建立安全数组变量。
                                (vlax-safearray-fill insertpoint2 insertpoint)                                 ;把插入点坐标值赋给安全数组变量insertpoint2。
                                (setq textobj (vla-AddText mSpace gaocheng insertpoint2 textheight_1))         ;创建文本对象,需要给三个参数:文字需要显示的高程值字符串 插入点坐标 文字高度。
                                (vla-put-Rotation textobj rotate_angle)                                        ;把文字应该旋转的角度赋值给此文字。
                                (vla-put-Alignment textobj 10)                                                 ;设置文字的对齐方式为正中,参数10为正中的意思。
                                (vla-put-Layer textobj "标注的高程文字")                                       ;把文字存储到新建立的图层。
                                (vla-put-TextAlignmentPoint textobj insertpoint2)                              ;设置文字对齐处的插入点,此行代码和上面的代码有先后顺序的区别。
                      );;progn2
                );;if1
        )
       
       


 ;----------------------------------------------------------------------------------------------------------------------------------------------------------
 ;----------------------------------------------------------------------------------------------------------------------------------------------------------
 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;打断文字压线的程序 1.0;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;                                                                                     ;;
;;   1、本程序的功能为:打断文字压线的程序。                                            ;;
;;                                                                                     ;;
;;   2、程序主命令为"tt",在命令行中输入"tt"按提示使用即可。                            ;;
;;                                                                                     ;;
;;                                                                                     ;;
;;                                                                      2011.8.10      ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;
 
 
 
 
              (defun C:TT (/ EN ENT EN_TEXT I J LST PT SS SS1 SS2)

                  (if    (setq SS (ssget '((0 . "TEXT"))))                ;利用'((0 . "TEXT"))在选择集中只选择文本对象。

                  (progn

                      (setq I 0)

                      (repeat (sslength SS)

                      (setq EN_TEXT (ssname SS I)

                            ENT     (entget EN_TEXT)

                            LST     (TEXTBOX2 ENT 1.0)                    ;调用子函数TEXTBOX2,参数1.0是缩放比例。

                      )

                      (if (setq SS1 (ssget "_f" LST '((0 . "POLYLINE"))))  ;修改POLYLINE可以定义选择的线的类型。

                          (progn

                          ;;计算中心点

                          (setq PT (mapcar '+ (nth 0 LST) (nth 2 LST))

                                PT (mapcar '* '(0.5 0.5 0.5) PT)

                          )

              ;;;            ;;绘制边界

              ;;;            (command "_.PLINE")

              ;;;            (foreach PT LST

              ;;;                (command "non" PT)

              ;;;            )

              ;;;            (command "c" "")

              ;;;            (setq SS2 (entlast))

                          ;;

                          (setq J 0)

                          (repeat    (sslength SS1)

                              (setq EN (ssname SS1 J))

                              ;;剪切操作

                              ;;(command "_.trim" SS2 "" (list EN PT) "")

                              (command "_.trim" EN_TEXT "" (list EN PT) "")

                              ;;

                              (setq J (1+ J))

                          )

              ;;;            ;;删除边界

              ;;;            (entdel SS2)

                          )

                      )

                      (setq I (1+ I))

                      )

 

                  )

                  )

                  (princ)

              )

              ;;;=======================================================

              ;;;    通用函数

              ;;;功能:获取TEXT对象包围盒四个角点

              ;;;参数:ENT ----text组码表

              ;;;参数:SC  ----缩放比例

              (defun TEXTBOX2    (ENT SC    / PT0 ANG LST PTA PTB PTC PTD
              LST_NEW PT_ANG PT_DIST)

                  ;;插入点 角度

                  (setq PT0 (cdr (assoc 10 ENT))

                    ANG (cdr (assoc 50 ENT))

                  )

                  ;;计算局部坐标系四点

                  (setq LST (textbox ENT))

                  (setq PTA (car LST)

                    PTB (cadr LST)

                  )

                  (setq PTC (list (car PTA) (cadr PTB))

                    PTD (list (car PTB) (cadr PTA))

                  )

                  (setq LST      (list PTA PTC PTB PTD)

                    LST_NEW ()

                  )

                  ;;旋转坐标系

                  (foreach PT    LST

                  (setq PT_DIST (distance '(0 0 0) PT)

                        PT_ANG  (angle '(0 0 0) PT)

                        PT      (polar '(0 0 0) (+ PT_ANG ANG) (* SC PT_DIST))

                        LST_NEW (cons PT LST_NEW)

                  )

                  )

                  ;;平移

                  (setq LST '())

                  (foreach PT    LST_NEW

                  (setq PT  (mapcar '+ PT0 PT)

                        LST (cons PT LST)

                  )

                  )

                  ;;返回

                  LST

              )

 

 

 ;----------------------------------------------------------------------------------------------------------------------------------------------------------
 ;----------------------------------------------------------------------------------------------------------------------------------------------------------
 

0

阅读 收藏 喜欢 打印举报/Report
  

新浪BLOG意见反馈留言板 欢迎批评指正

新浪简介 | About Sina | 广告服务 | 联系我们 | 招聘信息 | 网站律师 | SINA English | 产品答疑

新浪公司 版权所有