分享一个自己CAD表格转EXCEL源程序

Option Explicit
Public Sub Cad表格转Excel()
Dim objEntArr() As Object, i As Long
Dim objSset As AcadSelectionSet
Dim Y As AcadSelectionSet
Dim pt1(2) As Double, pt2(2) As Double, na$
Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k
'pt1,pt2是表格的位置，左下，右上
pt1(0) = -1500
pt1(1) = -1500
pt1(2) = 0
pt2(0) = 43200
pt2(1) = 43200
pt2(2) = 0
na = "QQQ"
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
    Set Y = ThisDrawing.SelectionSets.Item(na)
    Y.Delete
End If
Set Y = ThisDrawing.SelectionSets.Add(na)
      Dim gpCode(0) As Integer
      Dim dataValue(0) As Variant
      gpCode(0) = 0
      dataValue(0) = "text,mtext"
      Dim groupCode As Variant, dataCode As Variant
      groupCode = gpCode
      dataCode = dataValue
Y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode
    For i = 0 To Y.Count - 1
        A(i + 1, 1) = i
        A(i + 1, 2) = Y.Item(i).TextString
        p = Y.Item(i).InsertionPoint
        A(i + 1, 3) = p(0)
        A(i + 1, 4) = p(1)
    Next i
 Y.Delete
k = 50     'k是过滤间隙
B = 过滤数组(A, 4, k)
C = 过滤数组(A, 3, k + 5)
ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
For i = 1 To UBound(A)
    If A(i, 2) = "" Then Exit For
    For n = 0 To UBound(B)
        '行的位置
        If Abs(B(n) - A(i, 4))  A(j + 1) Then
            n = A(j + 1)
            A(j + 1) = A(j)
            A(j) = n
        End If
    Next j
Next i
冒泡排序 = A
End Function

ii443wutrhg.jpg

vt5nb3lvw1y.jpg

Option Explicit
Public Sub Cad表格转Excel()
Dim objEntArr() As Object, i As Long
Dim objSset As AcadSelectionSet
Dim y As AcadSelectionSet
'Dim pt1(2) As Double, pt2(2) As Double
Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$
Dim E()
'pt1,pt2是表格的位置，左下，右上
'pt1(0) = -1500
'pt1(1) = -1500
'pt1(2) = 0
'pt2(0) = 43200
'pt2(1) = 43200
'pt2(2) = 0
Dim pt1, pt2
pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
na = "QQQ"
k = 0
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
    Set y = ThisDrawing.SelectionSets.Item(na)
    y.Delete
End If
Set y = ThisDrawing.SelectionSets.Add(na)
      Dim gpCode(0) As Integer
      Dim dataValue(0) As Variant
      gpCode(0) = 0
      dataValue(0) = "text,mtext"
      Dim groupCode As Variant, dataCode As Variant
      groupCode = gpCode
      dataCode = dataValue
  '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode
    For i = 0 To y.Count - 1
        A(i + 1, 1) = i
        A(i + 1, 2) = y.Item(i).TextString
        p = y.Item(i).InsertionPoint
        k = IIf(y.Item(i).Height - k > 0, y.Item(i).Height, k)       'k是过滤间隙
        y.Item(i).GetBoundingBox m1, m2
        A(i + 1, 3) = p(0)
        A(i + 1, 4) = p(1)
        A(i + 1, 5) = (m1(0) + m2(0)) / 2          '文字中心坐标
        A(i + 1, 6) = (m2(0) - m1(0)) / 2          '文字长度的一半
        A(i + 1, 7) = (p(0) + A(i + 1, 5)) / 2     '插入点与文字中心坐标的中心点
        A(i + 1, 5) = A(i + 1, 5) + A(i + 1, 6) / 2.5    '文字中心坐标往右偏
    Next i
 y.Delete
' Stop
'k = 50     'k是过滤间隙
ky = k
kx = k * 1.2
B = 过滤数组(A, 4, ky)
C = 过滤数组(A, 7, kx)
'Stop
ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
For i = 1 To UBound(A)
    If A(i, 2) = "" Then Exit For
    For n = 0 To UBound(B)
        '行的位置
        If Abs(B(n) - A(i, 4))  A(j + 1) Then
            n = A(j + 1)
            A(j + 1) = A(j)
            A(j) = n
        End If
    Next j
Next i
冒泡排序 = A
End Function
Function 整合数组列(ByVal A, ByVal D, ByVal n)
'以中心点和插入点间距为判断
'当相连两列n列与n+1列比较，n+1列文字插入点或中心点在n列的插入点与中心点之间时，合并
'n列的插入点与中心点之间距离取该列最大值
Dim i, j, L, p, q, x1, x2, y, B, x3, x4
Dim C()
L = 0
If n >= UBound(D, 2) Then
    整合数组列 = D
    Exit Function
End If
'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标
For i = 1 To UBound(D)
    If D(i, n)  "" Then
        If InStr(D(i, n), "~~") > 0 Then
            B = Split(D(i, n), "~~")
            For j = 0 To UBound(B)
                y = Abs(A(B(j), 5) - A(B(j), 3))
                If L  "" Then
    'Stop
        If InStr(D(i, n + 1), "~~") > 0 Then
            B = Split(D(i, n + 1), "~~")
            For j = 0 To UBound(B)
                x3 = A(B(j), 3): x4 = A(B(j), 5)
                If IIf(x3 > x4, x4, x3)  x1, x2, x1) Then
                    p = 1
                    Exit For
                End If
            Next j
            Erase B
        Else
            x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)
            If IIf(x3 > x4, x4, x3)  x1, x2, x1) Then p = 1
        End If
        If p = 1 Then
            If D(i, n) = "" Then
                D(i, n) = D(i, n + 1)
            Else
                D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))
            End If
            D(i, n + 1) = ""
        End If
    End If
Next i
'Call excelqingchu(n)
'Call EXCEL输出(D)
C = 去除数组第N列空列(D, n + 1)
If UBound(C, 2)  "" Then 去除数组第N列空列 = D: Exit Function
Next i
ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)
For i = 1 To UBound(D)
    For j = 1 To UBound(C, 2)
        If j = n Then
            C(i, j) = D(i, j + 1)
        End If
    Next j
Next i
去除数组第N列空列 = C
End Function
Function 替换文字内容(ByVal A, ByVal D)
Dim B, i, j, k, n, m
For i = 1 To UBound(D)
    For j = 1 To UBound(D, 2)
        m = ""
        If D(i, j)  "" Then
            If InStr(D(i, j), "~~") > 0 Then
                B = Split(D(i, j), "~~")
                For k = 0 To UBound(B)
                    If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)
                Next k
                Erase B
            Else
                m = A(D(i, j), 2)
            End If
            D(i, j) = m
        End If
    Next j
Next i
替换文字内容 = D
End Function
Sub EXCEL输出(ByVal D)
Dim i, j, r
i = UBound(D)
j = UBound(D, 2)
Dim exlh As Object
Set exlh = GetObject(, "excel.application")
With exlh
    .workbooks(1).worksheets(1).Select
    .Sheets.Add
    'r = .cells(9999, 1).End(3).row + 2
    'If r 


5pakz0oqxpx.jpg







zsmlovwmfgk.jpg





[code]
Option Explicit
Public Sub Cad表格转Excel()
Dim objEntArr() As Object, i As Long
Dim objSset As AcadSelectionSet
Dim y As AcadSelectionSet
Dim pt1(2) As Double, pt2(2) As Double
Dim p, j, A(1 To 990, 1 To 7), B(), C(), D(), n, m, k, ky, kx, m1, m2, na$
Dim E()
'pt1,pt2是表格的位置，左下，右上
pt1(0) = -1500
pt1(1) = -1500
pt1(2) = 0
pt2(0) = 43200
pt2(1) = 43200
pt2(2) = 0
na = "QQQ"
k = 0
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item(na)) Then
    Set y = ThisDrawing.SelectionSets.Item(na)
    y.Delete
End If
Set y = ThisDrawing.SelectionSets.Add(na)
      Dim gpCode(0) As Integer
      Dim dataValue(0) As Variant
      gpCode(0) = 0
      dataValue(0) = "text,mtext"
      Dim groupCode As Variant, dataCode As Variant
      groupCode = gpCode
      dataCode = dataValue
  '    pt1 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
  '    pt2 = ThisDrawing.Utility.GetPoint(, "Enter a point: ")
y.Select acSelectionSetCrossing, pt1, pt2, groupCode, dataCode
    For i = 0 To y.Count - 1
        A(i + 1, 1) = i
        A(i + 1, 2) = y.Item(i).TextString
        p = y.Item(i).InsertionPoint
        k = IIf(y.Item(i).Height - k > 0, y.Item(i).Height, k)       'k是过滤间隙
        y.Item(i).GetBoundingBox m1, m2
        A(i + 1, 3) = p(0)
        A(i + 1, 4) = p(1)
        A(i + 1, 5) = (m1(0) + m2(0)) / 2          '文字中心坐标
        A(i + 1, 6) = (m2(0) - m1(0)) / 2          '文字长度的一半
        A(i + 1, 7) = (p(0) + A(i + 1, 5)) / 2     '插入点与文字中心坐标的中心点
    Next i
 y.Delete
' Stop
'k = 50     'k是过滤间隙
ky = k
kx = k * 1.2
B = 过滤数组(A, 4, ky)
C = 过滤数组(A, 7, kx)
ReDim D(1 To UBound(B) + 1, 1 To UBound(C) + 1)
For i = 1 To UBound(A)
    If A(i, 2) = "" Then Exit For
    For n = 0 To UBound(B)
        '行的位置
        If Abs(B(n) - A(i, 4))  A(j + 1) Then
            n = A(j + 1)
            A(j + 1) = A(j)
            A(j) = n
        End If
    Next j
Next i
冒泡排序 = A
End Function
Function 整合数组列(ByVal A, ByVal D, ByVal n)
'以中心点和插入点间距为判断
'当相连两列n列与n+1列比较，n+1列文字插入点或中心点在n列的插入点与中心点之间时，合并
'n列的插入点与中心点之间距离取该列最大值
Dim i, j, L, p, q, x1, x2, y, B, x3, x4
Dim C()
L = 0
If n >= UBound(D, 2) Then
    整合数组列 = D
    Exit Function
End If
'n列的插入点与中心点之间距离取该列最大值L及插入点和中心点X坐标
For i = 1 To UBound(D)
    If D(i, n)  "" Then
        If InStr(D(i, n), "~~") > 0 Then
            B = Split(D(i, n), "~~")
            For j = 0 To UBound(B)
                y = Abs(A(B(j), 5) - A(B(j), 3))
                If L > y Then
                    L = y
                    x1 = A(B(j), 3): x2 = A(B(j), 5)
                End If
            Next j
            Erase B
        Else
            y = Abs(A(D(i, n), 5) - A(D(i, n), 3))
            If L  "" Then
        If InStr(D(i, n + 1), "~~") > 0 Then
            B = Split(D(i, n + 1), "~~")
            For j = 0 To UBound(B)
                x3 = A(B(j), 3): x4 = A(B(j), 5)
                If IIf(x3 > x4, x4, x3)  x1, x2, x1) Then
                    p = 1
                    Exit For
                End If
            Next j
            Erase B
        Else
            x3 = A(D(i, n + 1), 3): x4 = A(D(i, n + 1), 5)
            If IIf(x3 > x4, x4, x3)  x1, x2, x1) Then p = 1
        End If
        If p = 1 Then
            If D(i, n) = "" Then
                D(i, n) = D(i, n + 1)
            Else
                D(i, n) = 纵向排列同一单元格文字(A, D(i, n) & "~~" & D(i, n + 1))
            End If
            D(i, n + 1) = ""
        End If
    End If
Next i
C = 去除数组第N列空列(D, n + 1)
If UBound(C, 2)  "" Then 去除数组第N列空列 = D: Exit Function
Next i
ReDim C(1 To UBound(D), 1 To UBound(D, 2) - 1)
For i = 1 To UBound(D)
    For j = 1 To UBound(C, 2)
        If j = n Then
            C(i, j) = D(i, j + 1)
        End If
    Next j
Next i
去除数组第N列空列 = C
End Function
Function 替换文字内容(ByVal A, ByVal D)
Dim B, i, j, k, n, m
For i = 1 To UBound(D)
    For j = 1 To UBound(D, 2)
        m = ""
        If D(i, j)  "" Then
            If InStr(D(i, j), "~~") > 0 Then
                B = Split(D(i, j), "~~")
                For k = 0 To UBound(B)
                    If m = "" Then m = A(B(k), 2) Else m = m & Chr(10) & A(B(k), 2)
                Next k
                Erase B
            Else
                m = A(D(i, j), 2)
            End If
            D(i, j) = m
        End If
    Next j
Next i
替换文字内容 = D
End Function