[VBA程序]：cad中表格转换到EXCEL中

king_time

Option Explicit
Public Sub bestt()
'link excel
Dim appexcel As Excel.Application
Dim worksheets As Excel.worksheets
Dim workbooks As Excel.workbooks
Dim workbook As Excel.workbook
Dim worksheet As Excel.worksheet
Dim worksheetname As String
Dim rowscount As Integer
Dim porline As Integer
Dim multinum As Integer
Dim mapserial As String
'worksheetname = InputBox("please enter the worksheetname:")
multinum = Val(InputBox("请输入倍数:"))
If multinum = 0 Then multinum = 1
mapserial = InputBox("请输入图纸号:")
On Error Resume Next
Set appexcel = GetObject(, "excel.Application")
'如果错误，启动新的EXCEL实例
If Err Then
Err.Clear
Set appexcel = CreateObject("excel.Application")
Set workbooks = appexcel.workbooks
Set workbook = workbooks.Add
Set worksheet = workbook.ActiveSheet
'如果EXCEL已经运行，关联用户输入的工作表
Else
Set workbook = appexcel.ActiveWorkbook
If worksheetname = "" Then
Set worksheet = workbook.ActiveSheet
Else
Set worksheet = workbook.Sheets(worksheetname)
End If
'如果工作表不存在，添加工作表
If Err Then
Err.Clear
Set worksheet = workbook.Sheets.Add()
worksheet.Name = worksheetname
End If
End If
rowscount = worksheet.range("a1").CurrentRegion.rows.count
Dim selectcount, objectcount, i, j, k, m, N, yesnotableline As Integer
Dim result, result1, controlp As Variant
Dim text As AcadText
Dim entity As AcadEntity
Dim selects As AcadSelectionSet
Dim restrictp As New Collection
ThisDrawing.SelectionSets.Item("r").Delete
If Err Then
Set selects = ThisDrawing.SelectionSets.Add("r")
Err.Clear
End If
'define filter
Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
Dim groupCode As Variant, dataCode As Variant
gpCode(0) = 0
dataValue(0) = "text"
groupCode = gpCode
dataCode = dataValue
Dim judgeselectp As Integer
Dim pointarray As Variant
Dim tablescale As Double
'tablescale = ThisDrawing.Utility.GetReal("please enter the table scale")
tablescale = 25
If tablescale = 0 Then tablescale = 1
pointarray = Array(0, 11.82, 71.82, 81.82, 94.82, 111.82, 126.82, 141.82, 179.85)
judgeselectp = 0
If judgeselectp = 1 Then
On Error GoTo errorhandle
Do While Not Err
controlp = ThisDrawing.Utility.GetPoint(, "选择点:")
restrictp.Add controlp(0)
Loop
Else
controlp = ThisDrawing.Utility.GetPoint(, "选择点:")
restrictp.Add controlp(0) + pointarray(0) * tablescale
For i = 1 To UBound(pointarray)
restrictp.Add controlp(0) + pointarray(i) * tablescale
Next i
End If
'End Select
errorhandle:
'MsgBox "ok?"
On Error Resume Next
ThisDrawing.Utility.Prompt "请选择所要转换的文本"
selects.SelectOnScreen groupCode, dataCode
objectcount = selects.count
Dim colectionobj As New Collection
Dim colectionxt As New Collection
Dim colectionx As New Collection
Dim colectiony As New Collection
Dim colectionxb As New Collection
Dim colectionxf As New Collection
Dim textheight As Double
Dim maxrownum As Integer
Dim sort As New Collection
Dim p1, p2, p3, p4
textheight = selects(1).height
For Each text In selects
colectionobj.Add text
Next text
selects.Delete
Set sort = Sort2(colectionobj, textheight)
Dim kkk1, kkk2 As Double
For i = 1 To sort.count
For m = 1 To restrictp.count - 1
For Each j In sort(i)
p2 = j.InsertionPoint
kkk1 = restrictp(m)
kkk2 = restrictp(m + 1)
If restrictp(m) < p2(0) And p2(0) < restrictp(m + 1) Then
If Not worksheet.Cells(i, m) = "" Then
worksheet.Cells(i + rowscount, m) = worksheet.Cells(i + rowscount, m) & " " & j.TextString
Else
worksheet.Cells(i + rowscount, m) = j.TextString
End If
End If
Next j
Next m
worksheet.Cells(i + rowscount, 9) = multinum
worksheet.Cells(i + rowscount, 10) = mapserial
Next i
'Application.WindowState = acMin
'appexcel.Visible = True
'workbook.Activate
'appexcel.WindowState = xlMaximized
End Sub
Public Function Sort2(Texts As Variant, textheight As Double) As Collection
'将选择集、Text数组或Text集合按X轴和Y轴进行排序，返回一个集合的集合
Dim total As New Collection
Dim pPnts As Collection
Dim Judge As Boolean
Dim i As AcadObject, j As Collection, k As Integer, l As Integer
Dim p1, p2, p3, p4
For Each i In Texts
Judge = False
For Each j In total
p1 = j(1).InsertionPoint: p2 = i.InsertionPoint
If Abs(p1(1) - p2(1)) < textheight Then
For k = 1 To j.count
p3 = j(k).InsertionPoint
If p3(0) >= p2(0) Then
j.Add i, , k
Judge = True
Exit For
End If
Next k
If Not Judge Then j.Add i: Judge = True
Exit For
End If
Next j
If Not Judge Then
Set pPnts = New Collection
pPnts.Add i
For l = 1 To total.count
p4 = total(l)(1).InsertionPoint
If p4(1) < p2(1) Then
total.Add pPnts, , l
Judge = True
Exit For
End If
Next l
If Not Judge Then total.Add pPnts
End If
Next i
Set Sort2 = total
End Function