分享一个excel表格转CAD的

qwh923820

程序是几个星期前写的，因为懒，就不改了，需要的人可以根据注释修改，很容易移植的。用了很久，暂时没发现BUG。

2. Sub 画表格填内容(ByVal pt, ByVal i, ByVal j, ByVal A, ByVal B)
   
3. 'B存放列宽，行高，字体大小
   
4. 'B第一行是列宽，第二行是行高，第三行是字高
   
5. 'p是左下角插入点,pt是左下角插入点
   
6. 'i行，j列
   
7. '列从左至右，行从下至上
   
8. 'A是EXCEL 里面要放的表格数据
   
9. Dim p1(0 To 2) As Double, p2(0 To 2) As Double, p3(0 To 2) As Double
   
10. Dim k&, x As Double, y As Double, z As Object
    
11. Dim zg As Double, p(0 To 2) As Double, w As Double, h As Double
    
12. 
    
13. zg = B(3, 1) * 35 / 50
    
14. h = B(3, 1)
    
15. 
    
16. '求左下角插入点p
    
17. p(1) = pt(1)
    
18. p(0) = pt(0)
    
19. For k = 1 To j
    
20.     p(0) = p(0) - B(1, k)
    
21. Next k
    
22. 
    
23. '画竖线
    
24. 
    
25. For k = 1 To i
    
26.      p2(1) = p2(1) + B(2, k)
    
27. Next k
    
28. p1(0) = p(0): p1(1) = p(1)
    
29. p2(0) = p1(0): p2(1) = p1(1) + p2(1)
    
30. Set z = acadDoc.modelspace.AddLine(p1, p2)
    
31. For k = 1 To j
    
32.     p1(0) = p1(0) + B(1, k)
    
33.     p2(0) = p1(0)
    
34.     Set z = acadDoc.modelspace.AddLine(p1, p2)
    
35. Next k
    
36. '画横线
    
37. p1(0) = p(0)
    
38. p2(1) = p(1)
    
39. Set z = acadDoc.modelspace.AddLine(p1, p2)
    
40. For k = 1 To i
    
41.     p1(1) = p1(1) + B(2, k)
    
42.     p2(1) = p1(1)
    
43.     Set z = acadDoc.modelspace.AddLine(p1, p2)
    
44. Next k
    
45. 
    
46. '放文字内容
    
47. '文字宽度 英文是35/50*zg，中文35/50*zg*2
    
48. p3(0) = p(0): p3(1) = p(1)
    
49. For y = 1 To j
    
50.     p3(0) = p3(0) + B(1, y)
    
51.     p3(1) = p(1)
    
52.     For x = 1 To i
    
53.         p3(1) = p3(1) + B(2, x)
    
54.         If A(x, y) <> "" Then
    
55.             w = 0
    
56.             For k = 1 To Len(A(x, y))
    
57.                 If Asc(Mid(A(x, y), k, 1)) > 0 Then
    
58.                     w = w + zg
    
59.                 Else
    
60.                     w = w + zg * 2
    
61.                 End If
    
62.             Next k
    
63.             p1(0) = p3(0) - w - (B(1, y) - w) / 2
    
64.             p1(1) = p3(1) - h - (B(2, x) - h) / 2
    
65.             Set z = acadDoc.modelspace.addtext(A(x, y), p1, h)
    
66.         End If
    
67.     Next x
    
68. Next y
    
69. End Sub

Sub 画表格填内容(ByVal pt, ByVal i, ByVal j, ByVal A, ByVal B)<br /> 'B存放列宽，行高，字体大小<br /> 'B第一行是列宽，第二行是行高，第三行是字高<br /> 'p是左下角插入点,pt是左下角插入点<br /> 'i行，j列<br /> '列从左至右，行从下至上<br /> 'A是EXCEL 里面要放的表格数据<br /> Dim p1(0 To 2) As Double, p2(0 To 2) As Double, p3(0 To 2) As Double<br /> Dim k&, x As Double, y As Double, z As Object<br /> Dim zg As Double, p(0 To 2) As Double, w As Double, h As Double<br /> <br /> zg = B(3, 1) * 35 / 50<br /> h = B(3, 1)<br /> <br /> '求左下角插入点p<br /> p(1) = pt(1)<br /> p(0) = pt(0)<br /> For k = 1 To j<br />     p(0) = p(0) - B(1, k)<br /> Next k<br /> <br /> '画竖线<br /> <br /> For k = 1 To i<br />      p2(1) = p2(1) + B(2, k)<br /> Next k<br /> p1(0) = p(0): p1(1) = p(1)<br /> p2(0) = p1(0): p2(1) = p1(1) + p2(1)<br /> Set z = acadDoc.modelspace.AddLine(p1, p2)<br /> For k = 1 To j<br />     p1(0) = p1(0) + B(1, k)<br />     p2(0) = p1(0)<br />     Set z = acadDoc.modelspace.AddLine(p1, p2)<br /> Next k<br /> '画横线<br /> p1(0) = p(0)<br /> p2(1) = p(1)<br /> Set z = acadDoc.modelspace.AddLine(p1, p2)<br /> For k = 1 To i<br />     p1(1) = p1(1) + B(2, k)<br />     p2(1) = p1(1)<br />     Set z = acadDoc.modelspace.AddLine(p1, p2)<br /> Next k<br /> <br /> '放文字内容<br /> '文字宽度 英文是35/50*zg，中文35/50*zg*2<br /> p3(0) = p(0): p3(1) = p(1)<br /> For y = 1 To j<br />     p3(0) = p3(0) + B(1, y)<br />     p3(1) = p(1)<br />     For x = 1 To i<br />         p3(1) = p3(1) + B(2, x)<br />         If A(x, y) <> "" Then<br />             w = 0<br />             For k = 1 To Len(A(x, y))<br />                 If Asc(Mid(A(x, y), k, 1)) > 0 Then<br />                     w = w + zg<br />                 Else<br />                     w = w + zg * 2<br />                 End If<br />             Next k<br />             p1(0) = p3(0) - w - (B(1, y) - w) / 2<br />             p1(1) = p3(1) - h - (B(2, x) - h) / 2<br />             Set z = acadDoc.modelspace.addtext(A(x, y), p1, h)<br />         End If<br />     Next x<br /> Next y<br /> End Sub

新鲜8

LZ代码全吗怎么使用呀

hefeilac

代码不全，能不能给个全面的代码？

t502435282

代码不全，能不能给个全面的代码？

雁苍山下人

非常感谢

yangchao2005090

雁苍山下人 发表于 2019-4-30 00:31
非常感谢

可否介绍一下使用方法