简单的VB源码(Excel表格转 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(".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