補leeyeafu說的具体程序编...
(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)
)
VBA编程实现，但......
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 我觉得在(command "_.ucs" "p")<BR>
后加上(command "point" ww)
(command "_.regen")
可能直观些.....
发现一个有意思的东东我改了一下lucas的程序(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的第二点即垂足。
如果不设及UCS，我想可从面外一点向面内任一直线AB做垂线，得垂足D；在面上过垂足D做AB的垂线CD；由面外点向CD所做垂线的垂足即所求点。
页:
1
[2]