Archive |mura's home- [AutoCAD掲示板 - 3D面と線の交点ポイントをとりたい]07060093|

３次元にかたむいた面と、それを通るラインとの交点のポイントを測りたいのですが可能でしょうか？

現在スラブレベルが３次元にひねっている車路スロープの作図をしているのですが、
面のいろいろなポイントのレベルをチェックしたいのです。

3DFACEで面を作成しそれに貫通するようにラインを引いて、２つの交点位置をひろえれば完璧なんですができません。
できないのであればこのような場合のコツをおしえていただければと思います。

非常に分かりにくい説明かと思いますがどなたか回答をいただけますと助かります。
よろしくお願い致します。

▼ あさ 2007/06/13(水) 11:07:46

著作権者の許可を得ていないため削除

▼ ヨッパライ 2007/06/14(木) 12:18:21

著作権者の許可を得ていないため削除

▼ コードレス [E-mail] 2007/06/14(木) 14:50:47

著作権者の許可を得ていないため削除

▼ kamegai [HOMEPAGE] 2007/06/14(木) 21:33:41

直線と(無限)平面との交点を取得する関数とサンプルプログラム(VBA)です。

平面と直線が平行で交点が無いにもかかわらず、計算誤差で求まってしまう場合があります。
直線の始終点が平面上にある場合、直線を延長しないと計算誤差で交点を求められない場合があります。
また、致命的な不具合があるかもしれません。長文失礼。

Option Explicit
'　開発・動作確認　2000i
'
Public Sub Test()
'サンプルプログラム
Dim Select3df  As AcadObject
Dim SelectLine As AcadObject
Dim PickPoint  As Variant
Dim Point3df   As Variant
Dim endPoint   As Variant
Dim startPoint As Variant
Dim pt(0 To 2) As Variant
Dim p3(0 To 2) As Variant
Dim p4(0 To 2) As Variant
Dim p5(0 To 2) As Variant
Dim MsgTmp     As String
Dim Response   As Variant
  On Error GoTo Err:
  With ActiveDocument
    .SendCommand Chr(3) & Chr(3)
    On Error Resume Next
    ActiveDocument.Utility.GetEntity Select3df, PickPoint, vbLf & "３Ｄ面を選択: "
    If Err Or Not Select3df.EntityName = "AcDbFace" Then
      .Utility.Prompt vbCr & "*３Ｄ面選択エラー* "
      Exit Sub
    End If
    ActiveDocument.Utility.GetEntity SelectLine, PickPoint, vbLf & "直線を指示: "
    If Err Or Not SelectLine.EntityName = "AcDbLine" Then
      .Utility.Prompt vbCr & "*直線選択エラー* "
      Exit Sub
    End If
    On Error GoTo Err:
    startPoint = SelectLine.startPoint
    endPoint = SelectLine.endPoint
    Point3df = Select3df.Coordinates
    p3(0) = Point3df(0): p3(1) = Point3df(1): p3(2) = Point3df(2)
    p4(0) = Point3df(3): p4(1) = Point3df(4): p4(2) = Point3df(5)
    p5(0) = Point3df(6): p5(1) = Point3df(7): p5(2) = Point3df(8)
    pt(0) = 0: pt(1) = 0: pt(2) = 0
    MsgTmp = ""
    MsgTmp = MsgTmp & "交差させるために直線を延長しますか？　" & vbCr
    Response = MsgBox(MsgTmp, vbYesNo, "Test")
    If Response = vbYes Then
    '[はい]直線を延長する
      Response = IofPSASL(startPoint, endPoint, p3, p4, p5, pt, True)
    Else
    '[いいえ]直線を延長しない
      Response = IofPSASL(startPoint, endPoint, p3, p4, p5, pt, False)
    End If
    If Not Response Then
      If IsEmpty(pt(0)) Then
        MsgTmp = ""
        MsgTmp = MsgTmp & "平面と直線が平行です　" & vbCr
      Else
        MsgTmp = ""
        MsgTmp = MsgTmp & "交点が見つかりません　" & vbCr
      End If
      MsgBox MsgTmp, vbOKOnly, "Test"
      Exit Sub
    Else
      'Prompt
      MsgTmp = ""
      MsgTmp = MsgTmp & "交点("
      MsgTmp = MsgTmp & pt(0) & ","
      MsgTmp = MsgTmp & pt(1) & ","
      MsgTmp = MsgTmp & pt(2) & ")"
      .Utility.Prompt vbCr & MsgTmp
      .SendCommand Chr(3)
      'メッセージ
      MsgTmp = ""
      MsgTmp = MsgTmp & "交点は、" & vbCr & vbCr
      MsgTmp = MsgTmp & " X= " & pt(0) & "   " & vbCr
      MsgTmp = MsgTmp & " Y= " & pt(1) & "   " & vbCr
      MsgTmp = MsgTmp & " Z= " & pt(2) & "   " & vbCr & vbCr
      MsgBox MsgTmp, vbOKOnly, "Test"
    End If
  End With
Exit Sub
Err:
  MsgTmp = ""
  MsgTmp = MsgTmp & "エラー　" & vbCr
  MsgBox MsgTmp, vbOKOnly, "IOfSandL"
  Exit Sub
End Sub
'
Private Function IofPSASL(p1, p2, p3, p4, p5, pt, Optional ExtendOption As Boolean = False) As Boolean
'直線と(無限)平面との交点取得 Ver.0.11 α版 Akinori Kamegai (C) 2007
'Intersection_of_plane_surface_and_straight_line
'　ExtendOption 交差させるために直線を延長するか
'
'　３点 p3(x1,y1,z1),p4(x2,y2,z2),p5(x3,y3,z3)の決定する平面
'　A=|X  Y  Z  1|=X|y1 z1 1|-Y|x1 z1 1|+Z|x1 y1 1|-1|x1 y1 z1|=0
'　  |x1 y1 z1 1|  |y2 z2 1|  |x2 z2 1|  |x2 y2 1|  |x2 y2 z2|
'　  |x2 y2 z2 1|  |y3 z3 1|  |x3 z3 1|  |x3 y3 1|  |x3 y3 z3|
'　  |x3 y3 z3 1|
'　A=  (y1z2+y2z3+y3z1-y1z3-y2z1-y3z2)X
'　   -(x1z2+x2z3+x3z1-x1z3-x2z1-x3z2)Y
'　   +(x1y2+x2y3+x3y1-x1y3-x2y1-x3y2)z
'　   -(x1y2z3+x2y3z1+x3y1z2-x1y3z2-x2y1z3-x3y2z1) = 0
'　各係数をa,b,c,dと置くと
'　A=aX+bY+cZ+d=0
'
'　２点 p1(x1,y1,z1),p2(x2,y2,z2)を通る直線
'　X-x1    Y-y1    Z-z1
'　----- = ----- = -----  (=Tと置くと)
'　x2-x1   y2-y1   z2-z1
'
'　X-x1=(x2-x1)T → X=x1+(x2-x1)T   ・・・(i)
'　Y-y1=(y2-y1)T → Y=y1+(y2-y1)T   ・・・(ii)
'　Z-z1=(z2-z1)T → Z=z1+(z2-z1)T   ・・・(iii)
'　A式に代入して
'　A=a(x1+(x2-x1)T)+b(y1+(y2-y1)T)+c(z1+(z2-z1)T)+d (=0)
'　 =ax1+a(x2-x1)T+by1+b(y2-y1)T+cz1+c(z2-z1)T+d    (=0)
'　 ={a(x2-x1)+b(y2-y1)+c(z2-z1)}T+(ax1+by1+cz1+d)  (=0)
'　よって
'　T=-(ax1+by1+cz1+d)/{a(x2-x1)+b(y2-y1)+c(z2-z1)}
'
'　Tを(i)～(iii)に代入して交点 X,Y,Z を得る
'
'  戻り値　正常終了 True [Boolean]
'　　　  　異常終了 False [Boolean]
'
Dim A  As Double
Dim B  As Double
Dim C  As Double
Dim D  As Double
Dim x1 As Double
Dim x2 As Double
Dim x3 As Double
Dim y1 As Double
Dim y2 As Double
Dim y3 As Double
Dim z1 As Double
Dim z2 As Double
Dim z3 As Double
Dim L1 As Double
Dim L2 As Double
Dim T  As Double
Dim EN As Double
  On Error GoTo Err:
  '平面の係数算出
  x1 = p3(0): x2 = p4(0): x3 = p5(0)
  y1 = p3(1): y2 = p4(1): y3 = p5(1)
  z1 = p3(2): z2 = p4(2): z3 = p5(2)
  A = y1 * z2 + y2 * z3 + y3 * z1 - y1 * z3 - y2 * z1 - y3 * z2
  B = -1 * (x1 * z2 + x2 * z3 + x3 * z1 - x1 * z3 - x2 * z1 - x3 * z2)
  C = x1 * y2 + x2 * y3 + x3 * y1 - x1 * y3 - x2 * y1 - x3 * y2
  D = -1 * (x1 * y2 * z3 + x2 * y3 * z1 + x3 * y1 * z2 - x1 * y3 * z2 - x2 * y1 * z3 - x3 * y2 * z1)
  '点と平面との距離取得
  L1 = PLine(p1, A, B, C, D)
  L2 = PLine(p2, A, B, C, D)
  '誤差
  EN = 0
  '交点チェック
  If IsEmpty(L1) Or IsEmpty(L2) Then
    ActiveDocument.Utility.Prompt vbLf & "*交点チェックエラー* "
    IofPSASL = False
    Exit Function
  ElseIf L1 - L2 = EN Then
  '交点無（平行）
  '　計算誤差で判別できないケース多々あり
    ActiveDocument.Utility.Prompt vbLf & "*交点無（平行）* "
    IofPSASL = False
    Erase pt
    Exit Function
  ElseIf Sgn(L1) * Sgn(L2) = 1 Then
  '交点無
    If Not ExtendOption Then
    '直線を延長しない
      IofPSASL = False
      Exit Function
    Else
    '直線を延長
    End If
  ElseIf Sgn(L1) * Sgn(L2) = -1 Or Sgn(L1) * Sgn(L2) = 0 Then
  '交点有（または、平面上に直線の始点または終点がある）
  Else
    IofPSASL = False
    Exit Function
  End If
  '交点算出
  x1 = p1(0): x2 = p2(0)
  y1 = p1(1): y2 = p2(1)
  z1 = p1(2): z2 = p2(2)
  T = -1 * (A * x1 + B * y1 + C * z1 + D) / (A * (x2 - x1) + B * (y2 - y1) + C * (z2 - z1))
  pt(0) = x1 + (x2 - x1) * T   'X
  pt(1) = y1 + (y2 - y1) * T   'Y
  pt(2) = z1 + (z2 - z1) * T   'Z
  IofPSASL = True
Exit Function
Err:
  ActiveDocument.Utility.Prompt vbLf & "*直線と平面との交点取得エラー* "
  IofPSASL = False
End Function
'
Private Function PLine(p1 As Variant, A As Double, B As Double, C As Double, D As Double) As Double
'点と平面との距離取得 Ver.0.11 α版 Akinori Kamegai (C) 2007
'Perpendicular_line
'　点 p1 [3d]
'　平面 Ax+By+Cz+D=0
'  戻り値　正常終了 距離 [Double]
'　　　  　異常終了 Empty [Double/Empty]
'
'　実際はPLineの絶対値であるが、
'　上記 Function IofPSASLにて
'　２点 p1(x1,y1,z1),p2(x2,y2,z2)を通る直線と
'　３点 p3(x1,y1,z1),p4(x2,y2,z2),p5(x3,y3,z3)の決定する平面
'　との交点の有無を確認する目的のため負値も可とする
'
  On Error GoTo Err:
  PLine = (A * p1(0) + B * p1(1) + C * p1(2) + D) / Sqr(A * A + B * B + C * C)
  '正しくはこちら
  'PLine = Abs(A * p1(0) + B * p1(1) + C * p1(2) + D) / Sqr(A * A + B * B + C * C)
Exit Function
Err:
  ActiveDocument.Utility.Prompt vbLf & "*点と平面との距離取得エラー* "
  PLine = Empty
End Function

3D面と線の交点ポイントをとりたい

▼ 梶野 2007/06/13(水) 09:34:21

▼ あさ 2007/06/13(水) 11:07:46

▼ ヨッパライ 2007/06/14(木) 12:18:21

▼ コードレス [E-mail] 2007/06/14(木) 14:50:47

▼ kamegai [HOMEPAGE] 2007/06/14(木) 21:33:41