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

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

本帖最后由作者于 2008-3-23 21:24:36 编辑  如题。在下刚学vba。如何编程获得用户输入两点后，画一直线，然后将坐标系转换到该直线上？谢谢！

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

本帖最后由作者于 2008-3-25 22:44:42 编辑 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

页: [1]

明经CAD社区's Archiver

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