|
|
[求助]请教此代码为何不能得到样条曲线拟合点的UCS坐标值，而只能得到其WCS坐标值？谢谢[br]Sub test_AddOrgUCS()
'原点UCS调用示例
Dim myUCS As AcadUCS, NewOrgPt As Variant
NewOrgPt = ThisDrawing.Utility.GetPoint(, vbCrLf & "请输入新原点：")
Set myUCS = AddOrgUCS(NewOrgPt, "abc")
ThisDrawing.ActiveUCS = myUCS
' This example selects a spline object in model space.
' It then finds the coordinates of the fit points.
Dim ssetObj As AcadSelectionSet
Set ssetObj = ThisDrawing.SelectionSets.Add("SSpline")
Dim fType As Variant, fData As Variant
Call CreateSSetFilter(fType, fData, 0, "Spline")
' 提示用户选择样条曲线对象并将它们添加到选择集中。
' 要完成选择，按回车。
ssetObj.SelectOnScreen fType, fData
ZoomAll
' Display the coordinates of the fit points
Dim fitPoint As Variant
Dim index As Integer
For i = 0 To ssetObj.count - 1
For index = 0 To ssetObj(i).NumberOfFitPoints - 1
fitPoint = ssetObj(i).GetFitPoint(index)
MsgBox "拟合点" & index + 1 & " 的坐标为： " & fitPoint(0) & ", " & fitPoint(1) & ", " & fitPoint(2), , "GetFitPoint Example"
Next
Next
End Sub
Public Sub CreateSSetFilter(ByRef filterType As Variant, ByRef filterData As Variant, ParamArray filter())
If UBound(filter) Mod 2 = 0 Then
MsgBox "filter参数无效！"
Exit Sub
End If
Dim fType() As Integer
Dim fData() As Variant
Dim count As Integer
count = (UBound(filter) + 1) / 2
ReDim fType(count - 1)
ReDim fData(count - 1)
Dim i As Integer
For i = 0 To count - 1
fType(i) = filter(2 * i)
fData(i) = filter(2 * i + 1)
Next i
filterType = fType
filterData = fData
End Sub
' 移动原点创建UCS
' ptOriginWcs：新UCS的原点在WCS中的坐标
Public Function AddOrgUCS(ptOriginWcs As Variant, strUcsName As String) As AcadUCS
' 获得新UCS原点在当前UCS中的坐标
Dim ptOriginUcs As Variant
ptOriginUcs = PtWcs2Ucs(ptOriginWcs)
'Debug.Print ptOriginWcs(0)
' 获得X、Y正半轴上任一点的UCS坐标
Dim ptXUcs(0 To 2) As Double, ptYUcs(0 To 2) As Double
ptXUcs(0) = ptOriginUcs(0) + 1
ptXUcs(1) = ptOriginUcs(1)
ptXUcs(2) = ptOriginUcs(2)
ptYUcs(0) = ptOriginUcs(0)
ptYUcs(1) = ptOriginUcs(1) + 1
ptYUcs(2) = ptOriginUcs(2)
' 获得X、Y正半轴上任一点的WCS坐标
Dim ptXWcs As Variant, ptYWcs As Variant
ptOriginWcs = PtUcs2Wcs(ptOriginUcs)
ptXWcs = PtUcs2Wcs(ptXUcs)
ptYWcs = PtUcs2Wcs(ptYUcs)
'Debug.Print ptOriginWcs(0)
' 创建UCS
Set AddOrgUCS = ThisDrawing.UserCoordinateSystems.Add(ptOriginWcs, ptXWcs, ptYWcs, strUcsName)
End Function
' 将点的UCS坐标转化到WCS坐标
Private Function PtUcs2Wcs(ptUcs As Variant) As Variant
PtUcs2Wcs = ThisDrawing.Utility.TranslateCoordinates(ptUcs, acUCS, acWorld, False)
End Function
' 将点的WCS坐标转化到UCS坐标
Private Function PtWcs2Ucs(ptWcs As Variant) As Variant
PtWcs2Ucs = ThisDrawing.Utility.TranslateCoordinates(ptWcs, acWorld, acUCS, False)
End Function |
|
置顶卡
