分享一个excel表格转CAD的

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