在UCS下画线出现问题
如题，为什么我第二次画的线和第三次画的线重合？代码如下：'CAD
Imports Autodesk..Interop
Imports Autodesk.AutoCAD.Interop.Common
Public Class Form1
Dim AcadApp As AcadApplication
Dim thisdrawing As AcadDocument
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
Try
AcadApp = GetObject("autocad.application")
Catch ex As Exception
Try
AcadApp = CreateObject("autocad.application")
Catch ex1 As Exception
MsgBox("无法打开AutoCAD")
Exit Sub
End Try
End Try
AcadApp.Visible = True
AppActivate(AcadApp.Caption)
thisdrawing = AcadApp.ActiveDocument
For i = 1 To 3
Dim origin(0 To 2) As Double
Call AddLine_UCS(1, 1, 0, 12, 12, 0)
'Dim origin(0 To 2) As Double
origin(0) = 8 : origin(1) = 8 : origin(2) = 0
Call MoveOriginUCS(origin, "MyUcs")
Next
End Sub
'通过移动坐标原点定义坐标系
Public Function MoveOriginUCS(ByVal originWcs As Object, ByVal ucsName As String) As AcadUCS
' 获得新UCS原点在当前UCS中的坐标
Dim originUcs As Object
originUcs = TranslatePointWcsToUcs(originWcs)
' 获得X、Y正半轴上任一点的UCS坐标
Dim ptXUcs(0 To 2) As Double, ptYUcs(0 To 2) As Double
ptXUcs(0) = originUcs(0) + 1
ptXUcs(1) = originUcs(1)
ptXUcs(2) = originUcs(2)
ptYUcs(0) = originUcs(0)
ptYUcs(1) = originUcs(1) + 1
ptYUcs(2) = originUcs(2)
' 获得X、Y正半轴上任一点的WCS坐标
Dim ptXWcs As Object, ptYWcs As Object
originWcs = TranslatePointUcsToWcs(originUcs)
ptXWcs = TranslatePointUcsToWcs(ptXUcs)
ptYWcs = TranslatePointUcsToWcs(ptYUcs)
' 创建UCS
MoveOriginUCS = thisdrawing.UserCoordinateSystems.Add(originWcs, ptXWcs, ptYWcs, ucsName)
'MoveOriginUCS = thisdrawing.UserCoordinateSystems.Add(originUcs, ptXUcs, ptYUcs, ucsName)
'' 显示 UCS 图标
'thisdrawing.ActiveViewport.UCSIconAtOrigin = True
'thisdrawing.ActiveViewport.UCSIconOn = True
'' 使新的 UCS 成为活动的 UCS
'thisdrawing.ActiveUCS = MoveOriginUCS
End Function
' 将点的坐标从UCS转换到WCS
Public Function TranslatePointUcsToWcs(ByVal ucsPoint As Object) As Object
Debug.Assert(VarType(ucsPoint) = vbArray + vbDouble)
Debug.Assert(LBound(ucsPoint) = 0 And UBound(ucsPoint) = 2)
TranslatePointUcsToWcs = thisdrawing.Utility.TranslateCoordinates(ucsPoint, AcCoordinateSystem.acUCS, AcCoordinateSystem.acWorld, False)
End Function
' 将点的坐标从WCS转换到UCS
Public Function TranslatePointWcsToUcs(ByVal wcsPoint As Object) As Object
Debug.Assert(VarType(wcsPoint) = vbArray + vbDouble)
Debug.Assert(LBound(wcsPoint) = 0 And UBound(wcsPoint) = 2)
TranslatePointWcsToUcs = thisdrawing.Utility.TranslateCoordinates(wcsPoint, AcCoordinateSystem.acWorld, AcCoordinateSystem.acUCS, False)
End Function
Public Function AddLine_UCS(ByVal p1x As Double, ByVal p1y As Double, ByVal p1z As Double, ByVal p2x As Double, ByVal p2y As Double, ByVal p2z As Double) As AcadLine
' 保存当前的UCS
Dim curUcs As AcadUCS
curUcs = GetActiveUCS()
' 返回到WCS
thisdrawing.ActiveUCS = GetWCS()
Dim ptStart(2) As Double
Dim ptEnd(2) As Double
ptStart(0) = p1x
ptStart(1) = p1y
ptStart(2) = p1z
ptEnd(0) = p2x
ptEnd(1) = p2y
ptEnd(2) = p2z
' 在WCS中创建轻量多段线
Dim objLine As AcadLine
objLine = thisdrawing.ModelSpace.AddLine(ptStart, ptEnd)
' 恢复保存的UCS
thisdrawing.ActiveUCS = curUcs
' 对长方体进行变换
Dim transMatrix As Object
transMatrix = curUcs.GetUCSMatrix()
objLine.TransformBy(transMatrix)
objLine.Update()
AddLine_UCS = objLine
End Function
Public Function GetWCS() As AcadUCS
' 定义创建UCS的三个点
Dim ptOrigin(2) As Double, ptXAxis(2) As Double, ptYAxis(2) As Double
ptOrigin(0) = 0 : ptOrigin(1) = 0 : ptOrigin(2) = 0
ptXAxis(0) = 1 : ptXAxis(1) = 0 : ptXAxis(2) = 0
ptYAxis(0) = 0 : ptYAxis(1) = 1 : ptYAxis(2) = 0
GetWCS = thisdrawing.UserCoordinateSystems.Add(ptOrigin, ptXAxis, ptYAxis, "WCS")
End Function
Public Function GetActiveUCS() As AcadUCS
If thisdrawing.GetVariable("UCSNAME") = "" Then
Dim ptOrigin(2) As Double ' 要创建的UCS的原点
Dim ptXAxis(2) As Double ' UCS的X轴正半轴上一点
Dim ptYAxis(2) As Double ' UCS的Y轴正半轴上一点
Dim xDir, yDir, org As Object' 当前UCS的参数
' 获得当前UCS的参数
xDir = thisdrawing.GetVariable("UCSXDIR")
yDir = thisdrawing.GetVariable("UCSYDIR")
org = thisdrawing.GetVariable("UCSORG")
' UCS的原点
ptOrigin(0) = org(0)
ptOrigin(1) = org(1)
ptOrigin(2) = org(2)
' 获得UCS的X轴正半轴上的一点
ptXAxis(0) = org(0) + xDir(0)
ptXAxis(1) = org(1) + xDir(1)
ptXAxis(2) = org(2) + xDir(2)
' 获得UCS的Y轴正半轴上的一点
ptYAxis(0) = org(0) + yDir(0)
ptYAxis(1) = org(1) + yDir(1)
ptYAxis(2) = org(2) + yDir(2)
' 创建和当前UCS重合的UCS
GetActiveUCS = thisdrawing.UserCoordinateSystems.Add(ptOrigin, ptXAxis, ptYAxis, "MyUCS")
thisdrawing.ActiveUCS = GetActiveUCS
Else
GetActiveUCS = thisdrawing.ActiveUCS
End If
End Function
End Class
问题已经解决了！ 楼上是怎么解决的啊？
页:
[1]