[求助]用lisp或vba编程实现：怎样通过由三点组成的平面（线框面）外一点做此面的垂

龙龙仔

(defun C:EE (/ PT1 PT2 PT3 PT4 WW)
  (command "_.ucs" "w")
  (setq PT1 (getpoint "\n第一点: "))
  (setq PT2 (getpoint PT1 "\n第二点: "))
  (grdraw PT1 PT2 3 1)
  (setq PT3 (getpoint PT2 "\n第三点: "))
  (grdraw PT2 PT3 3 1)
  (grdraw PT3 PT1 3 1)
  (setq PT4 (getpoint "\n面外点: "))
  (command "_.regen")
  (command "_.ucs" 3 PT1 PT2 PT3)
  (setq WW (list (car (trans PT4 0 1)) (cadr (trans PT4 0 1))))
  (setq WW (trans WW 1 0))
  (command "_.ucs" "p")
  (grdraw PT4 WW 3 1)
  (command "_.ucs" "p")
  (princ "\n垂点(世界坐标): ")
  (princ WW)
  (princ)
)

leeyeafu

Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant)
  Dim pt1, pt2, pt3, pt4 As Variant
  Dim objUCS, currUCS As AcadUCS
  pt1 = ThisDrawing.Utility.GetPoint(, "输入基准面第一点：")
  pt2 = ThisDrawing.Utility.GetPoint(, "第二点：")
  pt3 = ThisDrawing.Utility.GetPoint(, "第三点:")
  pt4 = ThisDrawing.Utility.GetPoint(, "面外点：")
  Set currUCS = ThisDrawing.ActiveUCS  '保存当前坐标系，用于处理完成后恢复坐标
  Set objUCS = ThisDrawing.UserCoordinateSystems.Add(pt1, pt2, pt3, "NewUCS")  '新建坐标系。程序在这容易出问题，若线pt1->pt2与线pt1->pt3不垂直，会发生Add方法错误，当然不是不可以改进，但若使用SendKeys方法或SendCommand方法，好象还不如直接使用龙兄的LISP实现。若用户输入三个点后，进行计算转换以保证垂直，又显得太麻烦，不知各位有无好办法？
  Dim N_pt4 As Variant
  ThisDrawing.ActiveUCS = objUCS
  N_pt4 = ThisDrawing.Utility.TranslateCoordinates(pt4, acWorld, acUCS, False)  '坐标变换，从世界坐标系到objUCS
  N_pt4(2) = 0  'Z坐标置零
  Dim ch As Variant
  ch = ThisDrawing.Utility.TranslateCoordinates(N_pt4, acUCS, acWorld, False)
  ThisDrawing.Utility.Prompt "垂足点：" & ch(0) & "  " & ch(1) & "  " & ch(2)
  ThisDrawing.ActiveUCS = currUCS
End Sub

ljcgq

我觉得在(command "_.ucs" "p")
后加上(command "point" ww) (command "_.regen") 可能直观些.....

无痕

发现一个有意思的东东我改了一下lucas的程序

2. (defun C:EE0 (/ PT1 PT2 PT3 PT4 WW)
3.    (command "_.ucs" "w")
4.    (setq PT1 (getpoint "\n第一点: "))
5.    (setq PT2 (getpoint PT1 "\n第二点: "))
6.    (grdraw PT1 PT2 3 1)
7.    (setq PT3 (getpoint PT2 "\n第三点: "))
8.    (grdraw PT2 PT3 3 1)
9.    (grdraw PT3 PT1 3 1)
10.    (command "_.ucs" 3 PT1 PT2 PT3)
11.    (setq PT4 (getpoint "\n面外点: "))
12.    (setq WW (list (car PT4) (cadr PT4) 0.0))
13.    (grdraw PT4 WW 3 1)
14.    (setq ww (trans ww 1 0))
15.    (command "_.ucs" "p" "_.ucs" "p")
16.    (princ "\n垂点(世界坐标): ")(princ ww)
17.    (princ)
18. )

(defun C:EE0 (/ PT1 PT2 PT3 PT4 WW)    (command "_.ucs" "w")    (setq PT1 (getpoint "\n第一点: "))    (setq PT2 (getpoint PT1 "\n第二点: "))    (grdraw PT1 PT2 3 1)    (setq PT3 (getpoint PT2 "\n第三点: "))    (grdraw PT2 PT3 3 1)    (grdraw PT3 PT1 3 1)    (command "_.ucs" 3 PT1 PT2 PT3)    (setq PT4 (getpoint "\n面外点: "))    (setq WW (list (car PT4) (cadr PT4) 0.0))    (grdraw PT4 WW 3 1)    (setq ww (trans ww 1 0))    (command "_.ucs" "p" "_.ucs" "p")    (princ "\n垂点(世界坐标): ")(princ ww)    (princ) )

测试结果：Command: ee
第一点:
第二点:
第三点:
面外点: mid of
垂点(世界坐标): (19950.3 12875.0 3.63798e-012)Command: ee0
第一点: 'osnap
当前对象捕捉模式: 端点,中点,圆心,交点,垂足
>>Enter list of object snap modes: int,end,mid,cen
第一点:
第二点:
第三点:
面外点:
垂点(世界坐标): (19950.3 12875.0 5.45697e-012)Command: id Specify point:   X = 19950.33452         Y = 12875.03564         Z = 0.00000ee是lucas原程序，ee0是我改的。 id命令查的是wcs下测试点的坐标。其中，ee和ee0返回的z值在不同测试环境/实体下，都不一样（也有等于0的）。我想是不是 x.xxe-0xx 被当成近似误差(cad bug)，其实就是0。

白李子

如果只是求垂足，可先将已知面设为当前UCS，再从面上任一点开始[PLINE]，下一点捕捉面外的那一点，PLINE的第二点即垂足。


如果不设及UCS，我想可从面外一点向面内任一直线AB做垂线，得垂足D；在面上过垂足D做AB的垂线CD；由面外点向CD所做垂线的垂足即所求点。