[求助]在vba中如何编程将坐标系转换到一根直线上？

lxdnn

 如题。在下刚学vba。如何编程获得用户输入两点后，画一直线，然后将坐标系转换到该直线上？谢谢！

lxdnn

Sub Example_ActiveUCS()
   
    Dim ucsObj As AcadUCS
    Dim origin As Variant
    Dim xAxisPoint(0 To 2) As Double
    Dim yAxisPoint(0 To 2) As Double
    Dim viewportObj As AcadViewport
    Dim x As Double, y As Double, z As Double, aa As Double, bb As Double, dd As Double
    Dim dist As Double

    ' Set the viewportObj variable to the activeviewport
    Set viewportObj = ThisDrawing.ActiveViewport
   
    Dim startPnt As Variant
    Dim endPnt As Variant
    Dim prompt1 As String
    Dim prompt2 As String
    prompt1 = vbCrLf & "Enter the start point of the line: "
    prompt2 = vbCrLf & "Enter the end point of the line: "

    ' 获取第一点

    startPnt = ThisDrawing.Utility.GetPoint(, prompt1)
   
    ' 获取第二点

    endPnt = ThisDrawing.Utility.GetPoint(, prompt2)

    ' 使用输入的两个点创建一条直线

    ThisDrawing.ModelSpace.AddLine startPnt, endPnt

    ThisDrawing.Application.ZoomAll

    ' 计算 point1 和 point2 之间的距离

   
    x = startPnt(0) - endPnt(0)

    y = startPnt(1) - endPnt(1)

    z = startPnt(2) - endPnt(2)
   
    dist = Sqr((Sqr((x ^ 2) + (y ^ 2)) ^ 2) + (z ^ 2))

    '显示计算出来的距离

    MsgBox "The distance between the points is: " _
                  & dist, , "Calculate Distance"

    aa = Abs(endPnt(1) - startPnt(1))
   
    bb = Abs(endPnt(0) - startPnt(0))
   
    dd = (aa * aa) / bb
   
   
    origin = startPnt

   xAxisPoint(0) = origin(0) + 1: xAxisPoint(1) = origin(1): xAxisPoint(2) = 0

   yAxisPoint(0) = origin(0): yAxisPoint(1) = origin(1) + 1: yAxisPoint(2) = 0

   Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPoint, yAxisPoint, "UCS1")
 
    xAxisPoint(0) = bb: xAxisPoint(1) = aa: xAxisPoint(2) = 0
    yAxisPoint(0) = -dd: yAxisPoint(1) = aa: yAxisPoint(2) = 0
  
 
    Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPoint, yAxisPoint, "TestUCS")
   
    ThisDrawing.ActiveUCS = ucsObj
   
    MsgBox "The new UCS is " & ucsObj.Name, vbInformation, "ActiveUCS Example"
    aa = 0
    bb = 0
    dd = 0
End Sub

但是以上程序仅在第一点选择wcs原点时才有效，否则就会提示y轴与x轴不垂直.能不能用translatecoordinates转换呢?但是我不会用,请斑竹赐教.不胜感激!

雪山飞狐_lzh

xAxisPoint和yAxisPoint是两轴上的点，而不是向量

Sub Example_ActiveUCS()
   
    Dim ucsObj As AcadUCS
    Dim origin As Variant
    Dim xAxisPoint
    Dim yAxisPoint
   
    Dim startPnt As Variant
    Dim endPnt As Variant
    Dim oLine As AcadLine
    Dim prompt1 As String
    Dim prompt2 As String
    prompt1 = vbCrLf & "Enter the start point of the line: "
    prompt2 = vbCrLf & "Enter the end point of the line: "
   
    startPnt = ThisDrawing.Utility.GetPoint(, prompt1)
    endPnt = ThisDrawing.Utility.GetPoint(startPnt, prompt2)
    Set oLine = ThisDrawing.ModelSpace.AddLine(startPnt, endPnt)
   

   
    Dim pnt(2) As Double
   
    origin = startPnt
    xAxisPoint = ThisDrawing.Utility.PolarPoint(startPnt, oLine.Angle, 1)
    yAxisPoint = ThisDrawing.Utility.PolarPoint(startPnt, oLine.Angle + Atn(1) * 2, 1)
 
    Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPoint, yAxisPoint, "TestUCS")
   
    ThisDrawing.ActiveUCS = ucsObj
   
    MsgBox "The new UCS is " & ucsObj.Name, vbInformation, "ActiveUCS Example"

End Sub