[VBA]Spline To Polyline 函数

macula

看了论坛里关于spline线转换为pline线方法的讨论，感觉都不尽人意就自己写了一个。自我感觉还可以特与大家分享：

3. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
4. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
5. ''                                                         ''
6. ''       Spline To Polyline 函数      ver 1.2              ''
7. ''                                                         ''
8. ''         调用函数：spl2pl()                              ''
9. ''                                                         ''
10. ''         作者：Macula       2005-11-23                   ''
11. ''                                                         ''
12. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
13. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
16. Sub Spl2pl()
17.   Dim sss As AcadSpline
18.   Dim o As AcadObject
19.   Dim ov As Variant
21.   ThisDrawing.SetVariable "REGENMODE", 1
23.   On Error Resume Next
24.   
25.   ThisDrawing.Utility.GetEntity o, ov, vbCrLf & "选择要转换的SPLINE："
26.   
27.   If Err.Number <> 0 Then
28.     ThisDrawing.Utility.Prompt "没有选择任何对象，退出！" & vbCrLf
29.     Err.Clear
30.     Exit Sub
31.   End If
32.   
33.   If o.ObjectName <> "AcDbSpline" Then
34.     ThisDrawing.Utility.Prompt "选择对象不是SPLINE，退出！" & vbCrLf
35.     Exit Sub
36.   Else
37.     Set sss = o
38.     Set o = Nothing
39.   End If
40.   
41.   Dim i As Long, j As Long
42.   Dim ns() As Double, n As Long
43.   Dim t As Variant
44.   
45.   '''''''''''''''''''''''''''''''''''''''''''''
46.   '          得到SPLINE拟点
47.   '''''''''''''''''''''''''''''''''''''''''''''
48.   n = sss.NumberOfFitPoints
49.   ReDim Preserve ns(n * 3 - 1)
50.   j = 0
51.   For i = 0 To n - 1
52.     t = sss.GetFitPoint(i)
53.     j = j + 1
54.     ns(j * 3 - 3) = t(0)
55.     ns(j * 3 - 2) = t(1)
56.     ns(j * 3 - 1) = t(2)
57.   Next
59.   Dim doc1 As AcadDocument, doc2 As AcadDocument
60.   Set doc1 = ThisDrawing.Application.ActiveDocument
61.   
62.   
63.   ''''''''''''''''''''''''''''''''''''''''''''''
64.   '        生成dxf文件
65.   ''''''''''''''''''''''''''''''''''''''''''''''
66.   Set doc2 = ThisDrawing.Application.Documents.Add("abc.dwg")
67.   doc2.ModelSpace.AddSpline ns, sss.StartTangent, sss.EndTangent
68.   doc2.SaveAs "tmp.dxf", acR12_dxf
69.   
70.   Dim tmpFileName As String
71.   
72.   tmpFileName = doc2.FullName
73.   doc2.Close
74.   Set doc2 = ThisDrawing.Application.Documents.Open(tmpFileName)
75.   
76.   Dim pl As Acad3DPolyline
77.   
78.   
79.   '''''''''''''''''''''''''''''''''''''''''''''
80.   '    由DXF文件生成PL线
81.   '''''''''''''''''''''''''''''''''''''''''''''
82.   Set pl = doc2.ModelSpace.Item(0)
83.   Err.Clear
84.   Dim od As Variant, nns() As Double
85.   j = -1
86.   Do While Err.Number = 0
87.     j = j + 1
88.     od = pl.Coordinate(j)
89.   Loop
90.   Err.Clear
91.   ReDim Preserve nns(j * 3 - 1)
92.   
93.   For i = 0 To j - 1
94.     od = pl.Coordinate(i)
95.     nns((i + 1) * 3 - 3) = od(0)
96.     nns((i + 1) * 3 - 2) = od(1)
97.     nns((i + 1) * 3 - 1) = od(2)
98.   Next
100.   doc1.Activate
101.   
102.   Dim pll As AcadPolyline
103.   Set pll = doc1.ModelSpace.AddPolyline(nns)
104.   pll.Layer = sss.Layer
105.   pll.Color = sss.Color
106.   sss.Delete
107.   Set sss = Nothing
108.   
109.   doc2.Close
110.   Set doc2 = Nothing
111.   Set doc1 = Nothing
112.   
113.   '''''''''''''''''''''''''''''''''''''''''''
114.   '      删除临时dxf文件
115.   '''''''''''''''''''''''''''''''''''''''''''
116.   tmpFileName = Replace(tmpFileName, "", "\")
117.   DelFile (tmpFileName)
118. End Sub
122. ''''''''''''''''''''''''''''''''''''''''''''''
123. '
124. '使用Script Fso对象模型删除文件
125. '
126. ''''''''''''''''''''''''''''''''''''''''''''''
127. Sub DelFile(ByVal fileName As String)
128.     Dim fso As New Scripting.FileSystemObject
129.     On Error Resume Next
130.     fso.DeleteFile fileName
131.     Set fso = Nothing
132. End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''' ''                                                         '' ''       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

BDYCAD

可以提点个人的意见吗? 我刚试了你的程序, 可以用vb写还行啦, 如果改进点就很好了, 因为转出来我觉的太密了,  呵呵.

tctabc

来用看看吧

谢谢提供

macula

谢谢斑竹的支持，关于点太密的问题我自己也在想解决的办法呢。