根据excel表格数据绘制图形

平凡的夏夜清风

这个有些行业非常实用！

鱼与熊掌

， 我就看看不说话

zjsru_18_505

看图中数据，图形是平行四边形。
试试这个，打开后，运行里面的宏。

http://bbs.mjtd.com/forum.php?mod=attachment&aid=ODY4NDR8MDZlYjBiMWU4YWMzODQ2OWE5MjBjNjg1YzZmOGI4ZjB8MTc0NzQwNjM0Mw%3D%3D&request=yes&_f=.rar

平凡的夏夜清风

zjsru_18_505 发表于 2015-1-27 19:10
看图中数据，图形是平行四边形。
试试这个，打开后，运行里面的宏。

怎么画出来的图是竖向排列，并且没有标注啊？

zjsru_18_505

1. Dim AutoCADObj As Object
   
2. Dim ActivedocumentObj As Object
   
3. Dim ModelspaceObj As Object
   
4. Dim LineObj As Object
   
5. Dim TextStyle As Object, TextString As Object
   
6. Dim LayerObj As Object
   
7. Dim start As Variant              '曲线起始点
   
8. Dim P0 As Variant
   
9. Dim StartPoint(0 To 2) As Double  '直线的起点
   
10. Dim EndPoint(0 To 2) As Double    '直线的终点
    
11. Dim POINT As Integer
    
12. Dim i As Integer
    
13. Dim DimObj As Object
    
14. 
    
15. 
    
16. 
    
17. 
    
18. Private Sub UserForm_Initialize()
    
19. 
    
20. On Error GoTo errtext
    
21. 
    
22. With Worksheets(1)
    
23. 
    
24. i = 1
    
25. Do While Trim(.Cells(i, 1)) <> ""
    
26. i = i + 1
    
27. Loop
    
28. 
    
29. POINT = i - 1                     '总的点数
    
30. 
    
31. 
    
32. 
    
33. 
    
34. End With
    
35. Exit Sub
    
36. 
    
37. errtext:
    
38. TextBox1.Text = "error"
    
39. End Sub
    
40. 
    
41. 
    
42. 
    
43. Private Sub CommandButton1_Click()
    
44. 
    
45. 
    
46. On Error GoTo obj
    
47. 
    
48. Set AutoCADObj = CreateObject("AutoCAD.Application")    '创建CAD对象
    
49. Set ActivedocumentObj = AutoCADObj.ActiveDocument         '创建绘图对象
    
50. Set ModelspaceObj = ActivedocumentObj.ModelSpace          '创建绘图空间对象
    
51. 
    
52. ''''''''''''''添加图层''''''''''''''''''''''''''''''''''''
    
53. Set LayerObj = ActivedocumentObj.Layers.Add("temp")
    
54.     'LayerObj.Color = 2
    
55.    
    
56. ''''''''''''''''添加文字样式''''''''''''''''''''''''''''''''''''''''
    
57. Set TextStyle = ActivedocumentObj.TextStyles.Add("st")    '添加新的文件样式st
    
58. TextStyle.SetFont "宋体", False, False, 1, 1           '指定样式st的字体为宋体
    
59. ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    
60. 
    
61. 
    
62. AutoCADObj.Application.Visible = True                     '使AutoCAD窗口显示
    
63. 
    
64. Dim A As Single
    
65. Dim B As Single
    
66. Dim C As Single
    
67. Dim D As Single
    
68. Dim ACR As Single
    
69. 
    
70. With Worksheets(1)
    
71. 
    
72. 
    
73. start = ActivedocumentObj.Utility.GetPoint(, "指定左下角：")
    
74. 
    
75. 
    
76. For i = 2 To POINT
    
77. 
    
78. 
    
79.     A = .Cells(i, 7)
    
80.     B = .Cells(i, 5)
    
81.     C = .Cells(i, 2)
    
82. 
    
83. 
    
84. 
    
85.     EndPoint(0) = start(0)
    
86.     EndPoint(1) = start(1)
    
87.     EndPoint(2) = start(2)
    
88.     StartPoint(0) = start(0) + C
    
89.     StartPoint(1) = start(1)
    
90.     StartPoint(2) = start(2)
    
91.     Call Line
    
92.    
    
93.     ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * A * B))
    
94.     P0 = ActivedocumentObj.Utility.PolarPoint(start, ACR, B)
    
95.     StartPoint(0) = EndPoint(0)
    
96.     StartPoint(1) = EndPoint(1)
    
97.     StartPoint(2) = EndPoint(2)
    
98.     EndPoint(0) = P0(0)
    
99.     EndPoint(1) = P0(1)
    
100.     EndPoint(2) = P0(2)
     
101.     Call Line
     
102.    
     
103.     P0 = ActivedocumentObj.Utility.PolarPoint(P0, 0, C)
     
104.     StartPoint(0) = EndPoint(0)
     
105.     StartPoint(1) = EndPoint(1)
     
106.     StartPoint(2) = EndPoint(2)
     
107.     EndPoint(0) = P0(0)
     
108.     EndPoint(1) = P0(1)
     
109.     EndPoint(2) = P0(2)
     
110.     Call Line
     
111.             
     
112.     StartPoint(0) = EndPoint(0)
     
113.     StartPoint(1) = EndPoint(1)
     
114.     StartPoint(2) = EndPoint(2)
     
115.     EndPoint(0) = start(0) + C
     
116.     EndPoint(1) = start(1)
     
117.     EndPoint(2) = start(2)
     
118.     Call Line
     
119.    
     
120.     StartPoint(0) = start(0) + C / 2
     
121.     StartPoint(1) = start(1)
     
122.     StartPoint(2) = start(2)
     
123.    
     
124.     start(0) = start(0) + C + B
     
125.     start(1) = start(1)
     
126.     start(2) = start(2)
     
127. 
     
128.    
     
129.    
     
130.     Set TextString = ModelspaceObj.AddText(.Cells(i, 1), StartPoint, CSng(TextBox1.Text) + 7.6)
     
131.     TextString.styleName = "st"                    '指定样式名
     
132.     TextString.layer = "temp"
     
133.     TextString.Alignment = 9                         '左中对齐
     
134.     TextString.Rotation = 3.14 / 2                   '旋转角度90度
     
135.     TextString.Textalignmentpoint = StartPoint        '重定义对齐点
     
136.     'TextString.Update                                '更新显示
     
137. 
     
138. Next
     
139. 
     
140. AutoCADObj.zoomall
     
141. 
     
142. End With
     
143. 
     
144. 'obj.Update                                          '刷新对象,使其更新
     
145. 'CADo.Quit                                           '退出对象
     
146. Set AutoCADObj = Nothing
     
147. Set ActivedocumentObj = Nothing
     
148. Set ModelspaceObj = Nothing
     
149. Set LineObj = Nothing
     
150. Set LayerObj = Nothing
     
151. Set TextString = Nothing
     
152. Set DimObj = Nothing
     
153. End
     
154. Exit Sub
     
155. 'Set obj = Nothing
     
156. obj:
     
157. MsgBox "对象已被清除或数据格式不对!", , "错误"
     
158. 
     
159. End Sub
     
160. 
     
161. 
     
162. 
     
163. Sub Line()
     
164. Dim x As Single, y As Single, DI As Single
     
165. Dim P1 As Variant
     
166. 
     
167. x = StartPoint(0) - EndPoint(0)
     
168. y = StartPoint(1) - EndPoint(1)
     
169. DI = Sqr(x * x + y * y) / 2
     
170. 
     
171. Set LineObj = ModelspaceObj.AddLine(StartPoint, EndPoint)
     
172. LineObj.layer = "temp"
     
173. 'LineObj.Update
     
174. 
     
175. P1 = ActivedocumentObj.Utility.PolarPoint(StartPoint, ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint), DI)
     
176. P1 = ActivedocumentObj.Utility.PolarPoint(P1, ActivedocumentObj.Utility.AngleFromXAxis _
     
177.      (StartPoint, EndPoint) + WorksheetFunction.Pi / 2, CSng(TextBox1.Text))
     
178. A = ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint)
     
179. 
     
180. Set DimObj = ModelspaceObj.AddDimAligned(StartPoint, EndPoint, P1)
     
181. DimObj.TextHeight = CSng(TextBox1.Text) / 2
     
182. DimObj.SuppressTrailingZeros = False
     
183.       
     
184. End Sub
     
185. 
     
186. 
     

Dim AutoCADObj As Object<br /> Dim ActivedocumentObj As Object<br /> Dim ModelspaceObj As Object<br /> Dim LineObj As Object<br /> Dim TextStyle As Object, TextString As Object<br /> Dim LayerObj As Object<br /> Dim start As Variant              '曲线起始点<br /> Dim P0 As Variant<br /> Dim StartPoint(0 To 2) As Double  '直线的起点<br /> Dim EndPoint(0 To 2) As Double    '直线的终点<br /> Dim POINT As Integer<br /> Dim i As Integer<br /> Dim DimObj As Object<br /> <br /> <br /> <br /> <br /> Private Sub UserForm_Initialize()<br /> <br /> On Error GoTo errtext<br /> <br /> With Worksheets(1)<br /> <br /> i = 1<br /> Do While Trim(.Cells(i, 1)) <> ""<br /> i = i + 1<br /> Loop<br /> <br /> POINT = i - 1                     '总的点数<br /> <br /> <br /> <br /> <br /> End With<br /> Exit Sub<br /> <br /> errtext:<br /> TextBox1.Text = "error"<br /> End Sub<br /> <br /> <br /> <br /> Private Sub CommandButton1_Click()<br /> <br /> <br /> On Error GoTo obj<br /> <br /> Set AutoCADObj = CreateObject("AutoCAD.Application")    '创建CAD对象<br /> Set ActivedocumentObj = AutoCADObj.ActiveDocument         '创建绘图对象<br /> Set ModelspaceObj = ActivedocumentObj.ModelSpace          '创建绘图空间对象<br /> <br /> ''''''''''''''添加图层''''''''''''''''''''''''''''''''''''<br /> Set LayerObj = ActivedocumentObj.Layers.Add("temp")<br />     'LayerObj.Color = 2<br />     <br /> ''''''''''''''''添加文字样式''''''''''''''''''''''''''''''''''''''''<br /> Set TextStyle = ActivedocumentObj.TextStyles.Add("st")    '添加新的文件样式st<br /> TextStyle.SetFont "宋体", False, False, 1, 1           '指定样式st的字体为宋体<br /> ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''<br /> <br /> <br /> AutoCADObj.Application.Visible = True                     '使AutoCAD窗口显示<br /> <br /> Dim A As Single<br /> Dim B As Single<br /> Dim C As Single<br /> Dim D As Single<br /> Dim ACR As Single<br /> <br /> With Worksheets(1)<br /> <br /> <br /> start = ActivedocumentObj.Utility.GetPoint(, "指定左下角：")<br /> <br /> <br /> For i = 2 To POINT<br /> <br /> <br />     A = .Cells(i, 7)<br />     B = .Cells(i, 5)<br />     C = .Cells(i, 2)<br /> <br /> <br /> <br />     EndPoint(0) = start(0)<br />     EndPoint(1) = start(1)<br />     EndPoint(2) = start(2)<br />     StartPoint(0) = start(0) + C<br />     StartPoint(1) = start(1)<br />     StartPoint(2) = start(2)<br />     Call Line<br />     <br />     ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * A * B))<br />     P0 = ActivedocumentObj.Utility.PolarPoint(start, ACR, B)<br />     StartPoint(0) = EndPoint(0)<br />     StartPoint(1) = EndPoint(1)<br />     StartPoint(2) = EndPoint(2)<br />     EndPoint(0) = P0(0)<br />     EndPoint(1) = P0(1)<br />     EndPoint(2) = P0(2)<br />     Call Line<br />     <br />     P0 = ActivedocumentObj.Utility.PolarPoint(P0, 0, C)<br />     StartPoint(0) = EndPoint(0)<br />     StartPoint(1) = EndPoint(1)<br />     StartPoint(2) = EndPoint(2)<br />     EndPoint(0) = P0(0)<br />     EndPoint(1) = P0(1)<br />     EndPoint(2) = P0(2)<br />     Call Line<br />             <br />     StartPoint(0) = EndPoint(0)<br />     StartPoint(1) = EndPoint(1)<br />     StartPoint(2) = EndPoint(2)<br />     EndPoint(0) = start(0) + C<br />     EndPoint(1) = start(1)<br />     EndPoint(2) = start(2)<br />     Call Line<br />     <br />     StartPoint(0) = start(0) + C / 2<br />     StartPoint(1) = start(1)<br />     StartPoint(2) = start(2)<br />     <br />     start(0) = start(0) + C + B<br />     start(1) = start(1)<br />     start(2) = start(2)<br /> <br />     <br />     <br />     Set TextString = ModelspaceObj.AddText(.Cells(i, 1), StartPoint, CSng(TextBox1.Text) + 7.6)<br />     TextString.styleName = "st"                    '指定样式名<br />     TextString.layer = "temp"<br />     TextString.Alignment = 9                         '左中对齐<br />     TextString.Rotation = 3.14 / 2                   '旋转角度90度<br />     TextString.Textalignmentpoint = StartPoint        '重定义对齐点<br />     'TextString.Update                                '更新显示<br /> <br /> Next<br /> <br /> AutoCADObj.zoomall<br /> <br /> End With<br /> <br /> 'obj.Update                                          '刷新对象,使其更新<br /> 'CADo.Quit                                           '退出对象<br /> Set AutoCADObj = Nothing<br /> Set ActivedocumentObj = Nothing<br /> Set ModelspaceObj = Nothing<br /> Set LineObj = Nothing<br /> Set LayerObj = Nothing<br /> Set TextString = Nothing<br /> Set DimObj = Nothing<br /> End<br /> Exit Sub<br /> 'Set obj = Nothing<br /> obj:<br /> MsgBox "对象已被清除或数据格式不对!", , "错误"<br /> <br /> End Sub<br /> <br /> <br /> <br /> Sub Line()<br /> Dim x As Single, y As Single, DI As Single<br /> Dim P1 As Variant<br /> <br /> x = StartPoint(0) - EndPoint(0)<br /> y = StartPoint(1) - EndPoint(1)<br /> DI = Sqr(x * x + y * y) / 2<br /> <br /> Set LineObj = ModelspaceObj.AddLine(StartPoint, EndPoint)<br /> LineObj.layer = "temp"<br /> 'LineObj.Update<br /> <br /> P1 = ActivedocumentObj.Utility.PolarPoint(StartPoint, ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint), DI)<br /> P1 = ActivedocumentObj.Utility.PolarPoint(P1, ActivedocumentObj.Utility.AngleFromXAxis _<br />      (StartPoint, EndPoint) + WorksheetFunction.Pi / 2, CSng(TextBox1.Text))<br /> A = ActivedocumentObj.Utility.AngleFromXAxis(StartPoint, EndPoint)<br /> <br /> Set DimObj = ModelspaceObj.AddDimAligned(StartPoint, EndPoint, P1)<br /> DimObj.TextHeight = CSng(TextBox1.Text) / 2<br /> DimObj.SuppressTrailingZeros = False<br />        <br /> End Sub<br /> <br /> <br />

平凡的夏夜清风

zjsru_18_505 发表于 2015-1-28 12:23

这次基本可以了，就是编号是竖向的，简单修改了下，可以了，学习了！！

平凡的夏夜清风

zjsru_18_505 发表于 2015-1-28 12:23

再请教下，图绘制出来后，对角线误差很大，是怎么回事？

zjsru_18_505

平凡的夏夜清风 发表于 2015-1-30 08:44
再请教下，图绘制出来后，对角线误差很大，是怎么回事？

有一句写错了。

    ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * A * B))

改为

    ACR = Application.WorksheetFunction.Acos((B * B + C * C - A * A) / (2 * C * B))

vink8023

可以添加个联系方式吗：我QQ：1079118454，需要找你定制插件