[求助]在vba中如何编程将坐标系转换到一根直线上？
如题。在下刚学vba。如何编程获得用户输入两点后，画一直线，然后将坐标系转换到该直线上？谢谢！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转换呢?但是我不会用,请斑竹赐教.不胜感激!
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
页:
[1]