[VBA程序]：Spline To Polyline 函数

macula55

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

2. 
   
3. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
4. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
   
5. ''                                                         ''
   
6. ''       Spline To Polyline 函数      ver 1.2              ''
   
7. ''                                                         ''
   
8. ''         调用函数：spl2pl()                              ''
   
9. ''                                                         ''
   
10. ''         作者：Macula       2005-11-23                   ''
    
11. ''                                                         ''
    
12. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
13. '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
14. 
    
15. 
    
16. Sub Spl2pl()
    
17.   Dim sss As AcadSpline
    
18.   Dim o As AcadObject
    
19.   Dim ov As Variant
    
20. 
    
21.   ThisDrawing.SetVariable "REGENMODE", 1
    
22. 
    
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
    
58. 
    
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
    
99. 
    
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
     
119. 
     
120. 
     
121. 
     
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
     
133. 
     

<br /> '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /> '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /> ''                                                         ''<br /> ''       Spline To Polyline 函数      ver 1.2              ''<br /> ''                                                         ''<br /> ''         调用函数：spl2pl()                              ''<br /> ''                                                         ''<br /> ''         作者：Macula       2005-11-23                   ''<br /> ''                                                         ''<br /> '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /> '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /> <br /> <br /> Sub Spl2pl()<br />   Dim sss As AcadSpline<br />   Dim o As AcadObject<br />   Dim ov As Variant<br /> <br />   ThisDrawing.SetVariable "REGENMODE", 1<br /> <br />   On Error Resume Next<br />   <br />   ThisDrawing.Utility.GetEntity o, ov, vbCrLf & "选择要转换的SPLINE："<br />   <br />   If Err.Number <> 0 Then<br />     ThisDrawing.Utility.Prompt "没有选择任何对象，退出！" & vbCrLf<br />     Err.Clear<br />     Exit Sub<br />   End If<br />   <br />   If o.ObjectName <> "AcDbSpline" Then<br />     ThisDrawing.Utility.Prompt "选择对象不是SPLINE，退出！" & vbCrLf<br />     Exit Sub<br />   Else<br />     Set sss = o<br />     Set o = Nothing<br />   End If<br />   <br />   Dim i As Long, j As Long<br />   Dim ns() As Double, n As Long<br />   Dim t As Variant<br />   <br />   '''''''''''''''''''''''''''''''''''''''''''''<br />   '          得到SPLINE拟点<br />   '''''''''''''''''''''''''''''''''''''''''''''<br />   n = sss.NumberOfFitPoints<br />   ReDim Preserve ns(n * 3 - 1)<br />   j = 0<br />   For i = 0 To n - 1<br />     t = sss.GetFitPoint(i)<br />     j = j + 1<br />     ns(j * 3 - 3) = t(0)<br />     ns(j * 3 - 2) = t(1)<br />     ns(j * 3 - 1) = t(2)<br />   Next<br /> <br />   Dim doc1 As AcadDocument, doc2 As AcadDocument<br />   Set doc1 = ThisDrawing.Application.ActiveDocument<br />   <br />   <br />   ''''''''''''''''''''''''''''''''''''''''''''''<br />   '        生成dxf文件<br />   ''''''''''''''''''''''''''''''''''''''''''''''<br />   Set doc2 = ThisDrawing.Application.Documents.Add("abc.dwg")<br />   doc2.ModelSpace.AddSpline ns, sss.StartTangent, sss.EndTangent<br />   doc2.SaveAs "tmp.dxf", acR12_dxf<br />   <br />   Dim tmpFileName As String<br />   <br />   tmpFileName = doc2.FullName<br />   doc2.Close<br />   Set doc2 = ThisDrawing.Application.Documents.Open(tmpFileName)<br />   <br />   Dim pl As Acad3DPolyline<br />   <br />   <br />   '''''''''''''''''''''''''''''''''''''''''''''<br />   '    由DXF文件生成PL线<br />   '''''''''''''''''''''''''''''''''''''''''''''<br />   Set pl = doc2.ModelSpace.Item(0)<br />   Err.Clear<br />   Dim od As Variant, nns() As Double<br />   j = -1<br />   Do While Err.Number = 0<br />     j = j + 1<br />     od = pl.Coordinate(j)<br />   Loop<br />   Err.Clear<br />   ReDim Preserve nns(j * 3 - 1)<br />   <br />   For i = 0 To j - 1<br />     od = pl.Coordinate(i)<br />     nns((i + 1) * 3 - 3) = od(0)<br />     nns((i + 1) * 3 - 2) = od(1)<br />     nns((i + 1) * 3 - 1) = od(2)<br />   Next<br /> <br />   doc1.Activate<br />   <br />   Dim pll As AcadPolyline<br />   Set pll = doc1.ModelSpace.AddPolyline(nns)<br />   pll.Layer = sss.Layer<br />   pll.Color = sss.Color<br />   sss.Delete<br />   Set sss = Nothing<br />   <br />   doc2.Close<br />   Set doc2 = Nothing<br />   Set doc1 = Nothing<br />   <br />   '''''''''''''''''''''''''''''''''''''''''''<br />   '      删除临时dxf文件<br />   '''''''''''''''''''''''''''''''''''''''''''<br />   tmpFileName = Replace(tmpFileName, "", "\")<br />   DelFile (tmpFileName)<br /> End Sub<br /> <br /> <br /> <br /> ''''''''''''''''''''''''''''''''''''''''''''''<br /> '<br /> '使用Script Fso对象模型删除文件<br /> '<br /> ''''''''''''''''''''''''''''''''''''''''''''''<br /> Sub DelFile(ByVal fileName As String)<br />     Dim fso As New Scripting.FileSystemObject<br />     On Error Resume Next<br />     fso.DeleteFile fileName<br />     Set fso = Nothing<br /> End Sub<br /> <br />

小玩童

程序不错，不过为什么转换成多段线后和未转换前不完全重合？见图,红色为样条曲线，白色为多段线

macula55

这个问题是矢量图型的问题，矢量图型中的坐标只有近似值没有标准值！

小玩童

获益匪浅，希望看到楼主更多的好程序，：）

gdzhou

利用R12 DXF文件不能存样条曲线吗？