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

lxdnn · 发表于 2008-3-23 21:23:00

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

3cgv5vxc1s2.JPG

lxdnn · 发表于 2008-3-25 22:39:00

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 · 发表于 2008-3-26 11:30:00

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

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

发表回复

精选推荐