[VBA]Spline To Polyline 函数
看了论坛里关于spline线转换为pline线方法的讨论，感觉都不尽人意就自己写了一个。自我感觉还可以特与大家分享：'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'' ''
'' Spline To Polyline 函数 ver 1.2 ''
'' ''
'' 调用函数：spl2pl() ''
'' ''
'' 作者：Macula 2005-11-23 ''
'' ''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Sub Spl2pl()
Dim sss As AcadSpline
Dim o As AcadObject
Dim ov As Variant
ThisDrawing.SetVariable "REGENMODE", 1
On Error Resume Next
ThisDrawing.Utility.GetEntity o, ov, vbCrLf & "选择要转换的SPLINE："
If Err.Number <> 0 Then
ThisDrawing.Utility.Prompt "没有选择任何对象，退出！" & vbCrLf
Err.Clear
Exit Sub
End If
If o.ObjectName <> "AcDbSpline" Then
ThisDrawing.Utility.Prompt "选择对象不是SPLINE，退出！" & vbCrLf
Exit Sub
Else
Set sss = o
Set o = Nothing
End If
Dim i As Long, j As Long
Dim ns() As Double, n As Long
Dim t As Variant
'''''''''''''''''''''''''''''''''''''''''''''
' 得到SPLINE拟点
'''''''''''''''''''''''''''''''''''''''''''''
n = sss.NumberOfFitPoints
ReDim Preserve ns(n * 3 - 1)
j = 0
For i = 0 To n - 1
t = sss.GetFitPoint(i)
j = j + 1
ns(j * 3 - 3) = t(0)
ns(j * 3 - 2) = t(1)
ns(j * 3 - 1) = t(2)
Next
Dim doc1 As AcadDocument, doc2 As AcadDocument
Set doc1 = ThisDrawing.Application.ActiveDocument
''''''''''''''''''''''''''''''''''''''''''''''
' 生成dxf文件
''''''''''''''''''''''''''''''''''''''''''''''
Set doc2 = ThisDrawing.Application.Documents.Add("abc.dwg")
doc2.ModelSpace.AddSpline ns, sss.StartTangent, sss.EndTangent
doc2.SaveAs "tmp.dxf", acR12_dxf
Dim tmpFileName As String
tmpFileName = doc2.FullName
doc2.Close
Set doc2 = ThisDrawing.Application.Documents.Open(tmpFileName)
Dim pl As Acad3DPolyline
'''''''''''''''''''''''''''''''''''''''''''''
' 由DXF文件生成PL线
'''''''''''''''''''''''''''''''''''''''''''''
Set pl = doc2.ModelSpace.Item(0)
Err.Clear
Dim od As Variant, nns() As Double
j = -1
Do While Err.Number = 0
j = j + 1
od = pl.Coordinate(j)
Loop
Err.Clear
ReDim Preserve nns(j * 3 - 1)
For i = 0 To j - 1
od = pl.Coordinate(i)
nns((i + 1) * 3 - 3) = od(0)
nns((i + 1) * 3 - 2) = od(1)
nns((i + 1) * 3 - 1) = od(2)
Next
doc1.Activate
Dim pll As AcadPolyline
Set pll = doc1.ModelSpace.AddPolyline(nns)
pll.Layer = sss.Layer
pll.Color = sss.Color
sss.Delete
Set sss = Nothing
doc2.Close
Set doc2 = Nothing
Set doc1 = Nothing
'''''''''''''''''''''''''''''''''''''''''''
' 删除临时dxf文件
'''''''''''''''''''''''''''''''''''''''''''
tmpFileName = Replace(tmpFileName, "\", "\\")
DelFile (tmpFileName)
End Sub
''''''''''''''''''''''''''''''''''''''''''''''
'
'使用Script Fso对象模型删除文件
'
''''''''''''''''''''''''''''''''''''''''''''''
Sub DelFile(ByVal fileName As String)
Dim fso As New Scripting.FileSystemObject
On Error Resume Next
fso.DeleteFile fileName
Set fso = Nothing
End Sub
可以提点个人的意见吗? 我刚试了你的程序, 可以用vb写还行啦, 如果改进点就很好了, 因为转出来我觉的太密了,呵呵. <P>来用看看吧</P>
<P>谢谢提供<BR></P> 谢谢斑竹的支持，关于点太密的问题我自己也在想解决的办法呢。
页:
[1]