一个测量立面图点标高的程序。

millermin

贡献一个自编的求点标高的程序。基线可以是水平线，即普通的标高问题。也可以是标高有变化的曲线，比如桥面上的构筑物，或者路面的围墙挡土墙等基线不平的情况。欢迎指正。自己觉得可以用，但构思不算巧妙，算是笨方法。


(defun c:test()
  (vl-load-com)
  (setq acadobject (vlax-get-acad-object))
  (setq acaddocument (vla-get-activedocument acadobject))
  (setq mspace (vla-get-modelspace acaddocument))
  
  (setq bl (car (entsel "\n CHOOSE a BASE LINE:")))
  (setq blv (vlax-ename->vla-object bl)
        blst (vlax-curve-getstartpoint blv)
        blend (vlax-curve-getendpoint blv))
  (setq blstx (car blst))  
  (setq blendx (car blend))
  (setq blsty (cadr blst))
  (setq blendy (cadr blend))  
   
   (if (> blstx blendx)
        (progn
        (setq x0 blstx)        
        (setq blstx blendx)
        (setq blendx x0)
        )
    )
  (while (= "")
     (setq tp (getpoint "\n CHOOSE A POINT TO CHECK LEVEL:"))      
       (if (< blstx (car tp) blendx)   
          (progn
             (if (= blsty blendy)
               (setq hei (- (cadr tp) blendy))
               (progn  
               (setq tpinser(distpoint tp blv))
               (setq hei(- (cadr tp) (cadr tpinser)))
                )
              )
                (print (strcat "THIS POINT LEVEL IS:"  "-------------" "[ " (rtos hei) " ]"))
                (prin1)
              )
          )  
       (if (or (> blstx (car tp)) (< blendx (car tp)))   
          (progn
             (if (= blsty blendy)
               (progn
                  (setq hei (- (cadr tp) blendy))
                  (print (strcat "THIS POINT LEVEL IS:"  "-------------" "[  " (rtos hei) "  ]"))
                  (prin1)
                )
                (progn  
                  (print (strcat"---------------------------------------------" "THIS POINT IS INVALID "  ))
                  (prin1)
                 )
               )  ; end if
             )   ; end progn
          )     ;end if
    )  ; end while
)

(defun distpoint(sp vlacurve)
         (setq sp1 (list (car sp)  (- (cadr sp) 100000) 0.0))
         (setq sp2 (list (car sp)  (+ (cadr sp) 100000) 0.0))
         (setq downv (vlax-make-safearray vlax-vbdouble'(0 . 2)))
         (vlax-safearray-fill downv sp1)
         (setq upv (vlax-make-safearray vlax-vbdouble'(0 . 2)))
         (vlax-safearray-fill upv sp2)
         
         (setq addlinev (vla-addline mspace upv downv))
         (setq crossv (vla-IntersectWith vlacurve addlinev acExtendNone))
              
         (setq addline (vlax-vla-object->ename addlinev))
         (command "erase" addline "")
         (setq cross (vlax-safearray->list (vlax-variant-value crossv)))
    )

skg123

能增加图面标注 的功能就更好