简单的VB源码(Excel表格转 CAD)

vbcad

本来想看看“VB源码(Excel CAD)表格互转”的源代码，结果没有看到附件，我来发一个简单的。单元格的行高、列宽、对齐方式、字体、合并等等 等等都没有考虑，只是演示了读5行3列的电子表格数据转化到CAD中。
过程：新建一个CAD文件、打开电子表格文件、画格子、读电子表格内容添加到CAD。
使用方法：新建工程，添加一个按钮，将下面的代码复制，也可以下载源码附件（包含一个测试用的电子表格文件）。

2. Private Sub Command1_Click()
   
3. Dim oBook As Object
   
4. Dim oSheet As Object
   
5. Dim oAcadDoc As Object
   
6. Dim txt As String
   
7. Set oAcadDoc = AcadNewFile() '新建一个CAD文件
   
8. Set oBook = ExcelBookOpen(App.Path & "\test.xls") '打开当前目录中文件名为的test电子表格
   
9. Set oSheet = oBook.ActiveSheet '获得test中的当前工作表
   
10. For Col = 1 To 3
    
11.     ColsW = ColsW + oSheet.Columns(Col).ColumnWidth '获得宽度
    
12. Next
    
13.     RowsH = 5 * 2 '获得高度
    
14. AcadSetFont oAcadDoc, "宋体" '将字体样式修改为宋体
    
15. AcadLine oAcadDoc, 0, -RowsH, RowsH, 90 '画竖线
    
16. AcadLine oAcadDoc, 0, -RowsH, ColsW, 0 '画横线
    
17. For Col = 1 To 3
    
18.     ColW = oSheet.Columns(Col).ColumnWidth '获得列宽
    
19.     For Row = 1 To 5
    
20.         txt = oSheet.cells(Row, Col) '读取电子表格中的数据，row代表行，col代表列
    
21.         AcadText oAcadDoc, txt, jColW + ColW / 2, -(Row - 1) * 2 - 1, 1 '写入文字，X=jColW + ColW / 2, Y=-(Row - 1) * 2 - 1,文字高度= 1
    
22.         If Col = 1 Then
    
23.             AcadLine oAcadDoc, 0, -(Row - 1) * 2, ColsW, 0 '画横线，x=0,y= -(Row - 1) * 1.5,长度= ColsW,角度= 0
    
24.         End If
    
25.    
    
26.     Next
    
27.     jColW = jColW + ColW '累加列宽
    
28.     AcadLine oAcadDoc, jColW, -RowsH, RowsH, 90 '画竖线
    
29. Next
    
30. 
    
31. End Sub
    
32. Public Function ExcelBookOpen(FilePath As String)
    
33. '打开excel工作簿，返回工作薄对象
    
34. '打开一个excel文件
    
35. Dim o_Excel As Object
    
36. Dim o_book As Object
    
37. Set o_Excel = CreateObject("Excel.Application") '建立电子表格实例
    
38. o_Excel.Visible = True '设置可见
    
39. Set o_book = o_Excel.Workbooks.Open(FilePath, 0) '打开文件
    
40. Set ExcelBookOpen = o_book '返回对象
    
41. End Function
    
42. Public Function AcadNewFile(Optional FileName As String = "")
    
43. '创建新图形
    
44. Dim o_AcadDoc As Object
    
45. Set o_Acad = CreateObject("AutoCAD.Application") '建立CAD实例
    
46. Set o_AcadDoc = o_Acad.Documents.Add '新建一个CAD文件
    
47. o_Acad.Visible = True '设置可见
    
48. Set AcadNewFile = o_AcadDoc '返回对象
    
49. End Function
    
50. Public Function AcadText(o_AcadDoc As Object, sText As String, X, y, h)
    
51.      ' 添加单行文字
    
52.      Dim o_Text As Object
    
53.     Dim Location(0 To 2) As Double
    
54.     Location(0) = X
    
55.     Location(1) = y
    
56.     Set o_Text = o_AcadDoc.ModelSpace.AddText(sText, Location, h)
    
57.    ' o_Text.Rotation = 0 '角度
    
58.     o_Text.Alignment = 10 '对齐方式（正中）
    
59.     o_Text.TextAlignmentPoint = Location '对齐到指定点
    
60.     o_Text.Update '更新
    
61.     Set AcadText = o_Text
    
62. End Function
    
63. Sub AcadLine(o_AcadDoc As Object, X, y, l, R)
    
64. '创建直线线
    
65. 'x,y为起点坐标 ，l为长度，r为角度
    
66. ' 确定直线的两个端点
    
67. Dim o_Line As Object
    
68. Dim x2 As Double
    
69. Dim y2 As Double
    
70. Dim startPoint(0 To 2) As Double
    
71. Dim endPoint(0 To 2) As Double
    
72. If R = 0 Or R = 180 Then
    
73.     x2 = X + l
    
74.     y2 = y
    
75. End If
    
76. If R = 90 Or R = 270 Then
    
77.     x2 = X
    
78.     y2 = y + l
    
79. End If
    
80. If R = -90 Or R = -270 Then
    
81.     x2 = X
    
82.     y2 = y - l
    
83. End If
    
84. '起点坐标
    
85. startPoint(0) = X
    
86. startPoint(1) = y
    
87. '终点坐标
    
88. endPoint(0) = x2
    
89. endPoint(1) = y2
    
90.    
    
91. ' 在模型空间创建一条直线
    
92. Set o_Line = o_AcadDoc.ModelSpace.AddLine(startPoint, endPoint)
    
93. End Sub
    
94. Public Sub AcadSetFont(o_AcadDoc As Object, Optional FontName As String = "宋体")
    
95. '设置字体
    
96.     Dim typeFace As String
    
97.     Dim SavetypeFace As String
    
98.     Dim Bold As Boolean
    
99.     Dim Italic As Boolean
    
100.     Dim charSet As Long
     
101.     Dim PitchandFamily As Long
     
102.    
     
103.         ' 获取当前设置
     
104.     o_AcadDoc.ActiveTextStyle.GetFont typeFace, _
     
105. Bold, Italic, charSet, PitchandFamily
     
106.   ' 改变字体
     
107. typeFace = FontName
     
108. o_AcadDoc.ActiveTextStyle.SetFont typeFace, _
     
109. Bold, Italic, charSet, PitchandFamily
     
110. End Sub
     

Private Sub Command1_Click()<br /> Dim oBook As Object<br /> Dim oSheet As Object<br /> Dim oAcadDoc As Object<br /> Dim txt As String<br /> Set oAcadDoc = AcadNewFile() '新建一个CAD文件<br /> Set oBook = ExcelBookOpen(App.Path & "\test.xls") '打开当前目录中文件名为的test电子表格<br /> Set oSheet = oBook.ActiveSheet '获得test中的当前工作表<br /> For Col = 1 To 3<br />     ColsW = ColsW + oSheet.Columns(Col).ColumnWidth '获得宽度<br /> Next<br />     RowsH = 5 * 2 '获得高度<br /> AcadSetFont oAcadDoc, "宋体" '将字体样式修改为宋体<br /> AcadLine oAcadDoc, 0, -RowsH, RowsH, 90 '画竖线<br /> AcadLine oAcadDoc, 0, -RowsH, ColsW, 0 '画横线<br /> For Col = 1 To 3<br />     ColW = oSheet.Columns(Col).ColumnWidth '获得列宽<br />     For Row = 1 To 5<br />         txt = oSheet.cells(Row, Col) '读取电子表格中的数据，row代表行，col代表列<br />         AcadText oAcadDoc, txt, jColW + ColW / 2, -(Row - 1) * 2 - 1, 1 '写入文字，X=jColW + ColW / 2, Y=-(Row - 1) * 2 - 1,文字高度= 1<br />         If Col = 1 Then<br />             AcadLine oAcadDoc, 0, -(Row - 1) * 2, ColsW, 0 '画横线，x=0,y= -(Row - 1) * 1.5,长度= ColsW,角度= 0<br />         End If<br />    <br />     Next<br />     jColW = jColW + ColW '累加列宽<br />     AcadLine oAcadDoc, jColW, -RowsH, RowsH, 90 '画竖线<br /> Next<br /> <br /> End Sub<br /> Public Function ExcelBookOpen(FilePath As String)<br /> '打开excel工作簿，返回工作薄对象<br /> '打开一个excel文件<br /> Dim o_Excel As Object<br /> Dim o_book As Object<br /> Set o_Excel = CreateObject("Excel.Application") '建立电子表格实例<br /> o_Excel.Visible = True '设置可见<br /> Set o_book = o_Excel.Workbooks.Open(FilePath, 0) '打开文件<br /> Set ExcelBookOpen = o_book '返回对象<br /> End Function<br /> Public Function AcadNewFile(Optional FileName As String = "")<br /> '创建新图形<br /> Dim o_AcadDoc As Object<br /> Set o_Acad = CreateObject("<a href="http://bbs.mjtd.com/forum-41-1.html" target="_blank" class="relatedlink">AutoCAD</a>.Application") '建立CAD实例<br /> Set o_AcadDoc = o_Acad.Documents.Add '新建一个CAD文件<br /> o_Acad.Visible = True '设置可见<br /> Set AcadNewFile = o_AcadDoc '返回对象<br /> End Function<br /> Public Function AcadText(o_AcadDoc As Object, sText As String, X, y, h)<br />      ' 添加单行文字<br />      Dim o_Text As Object<br />     Dim Location(0 To 2) As Double<br />     Location(0) = X<br />     Location(1) = y<br />     Set o_Text = o_AcadDoc.ModelSpace.AddText(sText, Location, h)<br />    ' o_Text.Rotation = 0 '角度<br />     o_Text.Alignment = 10 '对齐方式（正中）<br />     o_Text.TextAlignmentPoint = Location '对齐到指定点<br />     o_Text.Update '更新<br />     Set AcadText = o_Text<br /> End Function<br /> Sub AcadLine(o_AcadDoc As Object, X, y, l, R)<br /> '创建直线线<br /> 'x,y为起点坐标 ，l为长度，r为角度<br /> ' 确定直线的两个端点<br /> Dim o_Line As Object<br /> Dim x2 As Double<br /> Dim y2 As Double<br /> Dim startPoint(0 To 2) As Double<br /> Dim endPoint(0 To 2) As Double<br /> If R = 0 Or R = 180 Then<br />     x2 = X + l<br />     y2 = y<br /> End If<br /> If R = 90 Or R = 270 Then<br />     x2 = X<br />     y2 = y + l<br /> End If<br /> If R = -90 Or R = -270 Then<br />     x2 = X<br />     y2 = y - l<br /> End If<br /> '起点坐标<br /> startPoint(0) = X<br /> startPoint(1) = y<br /> '终点坐标<br /> endPoint(0) = x2<br /> endPoint(1) = y2<br />     <br /> ' 在模型空间创建一条直线<br /> Set o_Line = o_AcadDoc.ModelSpace.AddLine(startPoint, endPoint)<br /> End Sub<br /> Public Sub AcadSetFont(o_AcadDoc As Object, Optional FontName As String = "宋体")<br /> '设置字体<br />     Dim typeFace As String<br />     Dim SavetypeFace As String<br />     Dim Bold As Boolean<br />     Dim Italic As Boolean<br />     Dim charSet As Long<br />     Dim PitchandFamily As Long<br />     <br />         ' 获取当前设置<br />     o_AcadDoc.ActiveTextStyle.GetFont typeFace, _<br /> Bold, Italic, charSet, PitchandFamily<br />   ' 改变字体<br /> typeFace = FontName<br /> o_AcadDoc.ActiveTextStyle.SetFont typeFace, _<br /> Bold, Italic, charSet, PitchandFamily<br /> End Sub<br />

蟋蟀的帅

支持，我也是那个帖子找不到附件，来这里看看，谢谢。