简单的VB源码(Excel表格转 CAD)
本来想看看“VB源码(Excel CAD)表格互转”的源代码，结果没有看到附件，我来发一个简单的。单元格的行高、列宽、对齐方式、字体、合并等等 等等都没有考虑，只是演示了读5行3列的电子表格数据转化到CAD中。过程：新建一个CAD文件、打开电子表格文件、画格子、读电子表格内容添加到CAD。
使用方法：新建工程，添加一个按钮，将下面的代码复制，也可以下载源码附件（包含一个测试用的电子表格文件）。
Private Sub Command1_Click()
Dim oBook As Object
Dim oSheet As Object
Dim oAcadDoc As Object
Dim txt As String
Set oAcadDoc = AcadNewFile() '新建一个CAD文件
Set oBook = ExcelBookOpen(App.Path & "\test.xls") '打开当前目录中文件名为的test电子表格
Set oSheet = oBook.ActiveSheet '获得test中的当前工作表
For Col = 1 To 3
ColsW = ColsW + oSheet.Columns(Col).ColumnWidth '获得宽度
Next
RowsH = 5 * 2 '获得高度
AcadSetFont oAcadDoc, "宋体" '将字体样式修改为宋体
AcadLine oAcadDoc, 0, -RowsH, RowsH, 90 '画竖线
AcadLine oAcadDoc, 0, -RowsH, ColsW, 0 '画横线
For Col = 1 To 3
ColW = oSheet.Columns(Col).ColumnWidth '获得列宽
For Row = 1 To 5
txt = oSheet.cells(Row, Col) '读取电子表格中的数据，row代表行，col代表列
AcadText oAcadDoc, txt, jColW + ColW / 2, -(Row - 1) * 2 - 1, 1 '写入文字，X=jColW + ColW / 2, Y=-(Row - 1) * 2 - 1,文字高度= 1
If Col = 1 Then
AcadLine oAcadDoc, 0, -(Row - 1) * 2, ColsW, 0 '画横线，x=0,y= -(Row - 1) * 1.5,长度= ColsW,角度= 0
End If
Next
jColW = jColW + ColW '累加列宽
AcadLine oAcadDoc, jColW, -RowsH, RowsH, 90 '画竖线
Next
End Sub
Public Function ExcelBookOpen(FilePath As String)
'打开excel工作簿，返回工作薄对象
'打开一个excel文件
Dim o_Excel As Object
Dim o_book As Object
Set o_Excel = CreateObject("Excel.Application") '建立电子表格实例
o_Excel.Visible = True '设置可见
Set o_book = o_Excel.Workbooks.Open(FilePath, 0) '打开文件
Set ExcelBookOpen = o_book '返回对象
End Function
Public Function AcadNewFile(Optional FileName As String = "")
'创建新图形
Dim o_AcadDoc As Object
Set o_Acad = CreateObject("AutoCAD.Application") '建立CAD实例
Set o_AcadDoc = o_Acad.Documents.Add '新建一个CAD文件
o_Acad.Visible = True '设置可见
Set AcadNewFile = o_AcadDoc '返回对象
End Function
Public Function AcadText(o_AcadDoc As Object, sText As String, X, y, h)
' 添加单行文字
Dim o_Text As Object
Dim Location(0 To 2) As Double
Location(0) = X
Location(1) = y
Set o_Text = o_AcadDoc.ModelSpace.AddText(sText, Location, h)
' o_Text.Rotation = 0 '角度
o_Text.Alignment = 10 '对齐方式（正中）
o_Text.TextAlignmentPoint = Location '对齐到指定点
o_Text.Update '更新
Set AcadText = o_Text
End Function
Sub AcadLine(o_AcadDoc As Object, X, y, l, R)
'创建直线线
'x,y为起点坐标 ，l为长度，r为角度
' 确定直线的两个端点
Dim o_Line As Object
Dim x2 As Double
Dim y2 As Double
Dim startPoint(0 To 2) As Double
Dim endPoint(0 To 2) As Double
If R = 0 Or R = 180 Then
x2 = X + l
y2 = y
End If
If R = 90 Or R = 270 Then
x2 = X
y2 = y + l
End If
If R = -90 Or R = -270 Then
x2 = X
y2 = y - l
End If
'起点坐标
startPoint(0) = X
startPoint(1) = y
'终点坐标
endPoint(0) = x2
endPoint(1) = y2
' 在模型空间创建一条直线
Set o_Line = o_AcadDoc.ModelSpace.AddLine(startPoint, endPoint)
End Sub
Public Sub AcadSetFont(o_AcadDoc As Object, Optional FontName As String = "宋体")
'设置字体
Dim typeFace As String
Dim SavetypeFace As String
Dim Bold As Boolean
Dim Italic As Boolean
Dim charSet As Long
Dim PitchandFamily As Long
' 获取当前设置
o_AcadDoc.ActiveTextStyle.GetFont typeFace, _
Bold, Italic, charSet, PitchandFamily
' 改变字体
typeFace = FontName
o_AcadDoc.ActiveTextStyle.SetFont typeFace, _
Bold, Italic, charSet, PitchandFamily
End Sub
支持，我也是那个帖子找不到附件，来这里看看，谢谢。
页:
[1]