[原创]Auto CAD材料一览表数据到Excel

兰州人 · 发表于 2007-11-27 16:28:00

图示材料一览表是AutoCAD绘制施工图最常见表现形式。有人用属性块的方法处理方法见AutoCAD vba 二次开发教程第317页。

但在实际操作过程中，材料表的数据是任意方法写的，如

id	InsertText	InsertPointX	InsertPointY
2128357224	5-32	2.418415478	249.4999997
2128357240	1.2	138.8666674	217.4999997
2128357248	0.037	127.4444451	217.4999997
2128357256	8	111.8622229	217.4999997
2128357264	36	95.00888957	217.4999997
2128357272	螺母M16	43.50000068	217.4999997
2128357280	GB6170-86	17.04704513	217.4999997
2128357288	07RH09-04	15.76704513	161.4999997
2128357296	07RH09-06	15.76704513	153.4999997
2128357304	07RH09-06	15.76704513	129.4999997
2128357376	07RH09-04	15.76704513	57.49999969
2128357384	07RH09-05	15.76704513	49.49999969
2128357392	07RH09-05	15.76704513	41.49999969
2128357400	5-30	2.418415478	233.4999997

hadle,x,y数据是无序排序。

要实现以下目标，需要进行SQL+数组排序处理。

5-1	07RH09-03	固定管板I	1	16Mn/0Cr18Ni10Ti		914.5	其中不锈钢66.5kg
5-3	GB9948.SHJ405	接管 DN20 Sch80	2	20	0.2	0.4	L=108

zhouzhiy · 发表于 2017-11-8 18:02:23

谢谢楼主分享！

兰州人 · 发表于 2007-11-27 16:35:00

本帖最后由作者于 2008-7-23 14:48:48 编辑

SQL+mdb处理方法
' 从数据库中读取数据
Sub ReadFromMdbFile()
' 创建数据库连接
Dim YCount, nn As Integer
Dim XDistinct, YDistinct
Call CreateConnection
Dim rst As ADODB.Recordset, ii As Integer
' 在line表中查询所有的记录
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
'Distinct Y 统计Y坐标的不重复数量
rst.Open "SELECT val(format(InsertPointY,'0.00')) FROM EntityText" & _
      " Group By val(Format(InsertPointY,'0.00'))" & _
      " Order By val(Format(InsertPointY,'0.00'))  " & _
      "", cn, adOpenForwardOnly, _
         adLockBatchOptimistic, adCmdText
rst.MoveFirst
ReDim YDistinct(rst.RecordCount - 1)
For ii = 0 To rst.RecordCount - 1
   YDistinct(ii) = rst.Fields(0).Value
   Debug.Print YDistinct(ii)
   rst.MoveNext
Next ii
rst.Close
1.5
9.5
17.5
25.5
33.5
41.5
49.5
57.5
65.5
73.5
81.5
89.5
97.5

'Distinct X 统计X坐标的不重复数据的数量
rst.Open "SELECT val(format(InsertPointX,'0')) FROM EntityText" & _
      " Where  Format(InsertPointY,'0.00') = " & YDistinct(0) & _
      "", cn, adOpenForwardOnly, _
         adLockBatchOptimistic, adCmdText
rst.MoveFirst
ReDim XDistinct(rst.RecordCount - 1)
For ii = 0 To rst.RecordCount - 1
   XDistinct(ii) = rst.Fields(0).Value
   Debug.Print XDistinct(ii)
   rst.MoveNext
Next ii
rst.Close
运行结果8列数的X坐标范围。
3
16
44
96
102
137
148

End Sub
相关的ADO帮助文件.

2008-7-23

Sub ExcelToCadTable()
ThisDrawing.ActiveTextStyle.fontFile = "c:\windows\fonts\SIMHEI.ttf"
Dim colArray, rowBaseData
colArray = Array(404.55, 424, 455.11, 499, 510.11, 540.11, 550.69, 561.64)
rowBaseData = 84.71 - 6 - 8
Dim objText As AcadText
Dim xlSheet1
Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, alignmentPoint(0 To 2) As Double
Set xlSheet1 = ConnectExcel("Sheet1")
For ii = 40 To 1 Step -1
For jj = 0 To UBound(colArray) - 1
pp(0) = colArray(jj) + 2
pp(1) = rowBaseData + 8
tt = xlSheet1.Cells(ii, jj + 1)
Select Case jj
Case 5, 6
If Val(tt) < 1 And Val(tt) > 0 Then
tt = "0" & tt
End If
End Select
Set objText = ThisDrawing.ModelSpace.AddText(tt, pp, 4)
alignmentPoint(1) = pp(1)
Select Case jj
Case 2, 7
alignmentPoint(0) = colArray(jj) + 2
objText.Alignment = acAlignmentLeft
'objText.TextAlignmentPoint = alignmentPoint
Case Else
alignmentPoint(0) = colArray(jj) + (colArray(jj + 1) - colArray(jj)) / 2
objText.Alignment = acAlignmentCenter
objText.TextAlignmentPoint = alignmentPoint
End Select
'
Next jj
rowBaseData = rowBaseData + 8
Next ii
End Sub

Sub ExcelToCadTable()
  ThisDrawing.ActiveTextStyle.fontFile = "c:\windows\fonts\SIMHEI.ttf"
  Dim colArray, rowBaseData
  colArray = Array(404.55, 424, 455.11, 499, 510.11, 540.11, 550.69, 561.64)
  rowBaseData = 84.71 - 6 - 8
  Dim objText As AcadText
  Dim xlSheet1
  Dim pp(0 To 2) As Double, ppp(0 To 2) As Double, alignmentPoint(0 To 2) As Double
  Set xlSheet1 = ConnectExcel("Sheet1")
  For ii = 40 To 1 Step -1
    For jj = 0 To UBound(colArray) - 1
      pp(0) = colArray(jj) + 2
      pp(1) = rowBaseData + 8
      tt = xlSheet1.Cells(ii, jj + 1)
      Select Case jj
        Case 5, 6
          If Val(tt) < 1 And Val(tt) > 0 Then
            tt = "0" & tt
          End If
      End Select
      Set objText = ThisDrawing.ModelSpace.AddText(tt, pp, 4)
      alignmentPoint(1) = pp(1)
      Select Case jj
        Case 2, 7
          alignmentPoint(0) = colArray(jj) + 2
          objText.Alignment = acAlignmentLeft
          'objText.TextAlignmentPoint = alignmentPoint
        Case Else
          alignmentPoint(0) = colArray(jj) + (colArray(jj + 1) - colArray(jj)) / 2
          objText.Alignment = acAlignmentCenter
          objText.TextAlignmentPoint = alignmentPoint
      End Select
      '
    Next jj
    rowBaseData = rowBaseData + 8
  Next ii
End Sub

兰州人 · 发表于 2007-11-28 08:44:00

本帖最后由作者于 2007-12-9 21:32:46 编辑

AutoCAD2006以上版本使用属性块的方法如下

' 导出到Word中
Public Sub OutputToWord(ByVal SSetObj As AcadSelectionSet, ByVal LBObj As ListBox)
    Dim wdApp As Word.Application
    Dim wdDoc As Word.Document
    Dim wdTable As Word.Table

    Dim EntObj As AcadEntity
    Dim AttRefObjs As Variant
    Dim n As Integer
    Dim i As Integer
    Dim j As Integer

    On Error Resume Next
    ' 连接Word
    Set wdApp = GetObject(, "Word.Application")
    If Err Then
        Err.Clear
        Set wdApp = CreateObject("Word.Application")
        If Err Then
            Err.Clear
            MsgBox "无法启动Word，请检查是否正确安装！"
            Exit Sub
        End If
    End If
    wdApp.Visible = True

    On Error GoTo ErrTrap
    ' 返回新创建的文档
    Set wdDoc = wdApp.Documents.Add
    ' 返回在段落一之后新创建的表格
    Set wdTable = wdDoc.Tables.Add(wdDoc.Paragraphs(1).Range, 1, LBObj.ListCount)

    n = 0
    ' 遍历选择集
    For Each EntObj In SSetObj
        ' 增加行
        wdTable.Rows.Add
        ' 返回属性数据
        AttRefObjs = EntObj.GetAttributes
        n = n + 1
        For i = 0 To UBound(AttRefObjs)
            For j = 0 To LBObj.ListCount - 1
                If AttRefObjs(i).TagString = LBObj.List(j) And LBObj.Selected(j) = True Then
                    If n = 1 Then
                        ' 首行，标签做为表格的列标题
                        wdTable.Cell(n, j + 1).Range.Text = AttRefObjs(i).TagString
                        wdTable.Cell(n + 1, j + 1).Range.Text = AttRefObjs(i).TextString
                    Else
                        wdTable.Cell(n + 1, j + 1).Range.Text = AttRefObjs(i).TextString
                    End If
                End If
            Next
        Next
    Next

    ' 删除表格中的空列
    For i = LBObj.ListCount - 1 To 0 Step -1
        If wdTable.Cell(1, i + 1).Range.Text = vbCr + Chr(7) Then
            wdTable.Columns(i + 1).Delete
        End If
    Next

    ' 按序号排序
    wdTable.Sort True, "列 1"
    ' 自动调整列宽
    wdTable.AutoFitBehavior 1

    ' 释放Word对象
    Set wdTable = Nothing
    Set wdDoc = Nothing
    Set wdApp = Nothing
    Exit Sub

ErrTrap:
    On Error GoTo 0
End Sub

' 导出到Excel中
Public Sub OutputToExcel(ByVal SSetObj As AcadSelectionSet, ByVal LBObj As ListBox)
    Dim xlApp As Excel.Application
    Dim xlBook As Excel.Workbook
    Dim xlSheet As Excel.Worksheet

    Dim EntObj As AcadEntity
    Dim AttRefObjs As Variant
    Dim n As Integer
    Dim i As Integer
    Dim j As Integer

    On Error Resume Next
    ' 连接Excel
    Set xlApp = GetObject(, "Excel.Application")
    If Err Then
        Err.Clear
        Set xlApp = CreateObject("Excel.Application")
        If Err Then
            Err.Clear
            MsgBox "无法启动Word，请检查是否正确安装！"
            Exit Sub
        End If
    End If
    xlApp.Visible = True

    On Error GoTo ErrTrap
    ' 返回新创建的工作簿
    Set xlBook = xlApp.Workbooks.Add
    ' 返回新增加的工作表，并移动到最后一个
    Set xlSheet = xlBook.Worksheets.Add
    xlSheet.Move , xlBook.Worksheets(xlBook.Worksheets.Count)

    n = 0
    ' 遍历选择集
    For Each EntObj In SSetObj
        ' 返回属性数据
        AttRefObjs = EntObj.GetAttributes
        n = n + 1
        For i = 0 To UBound(AttRefObjs)
            For j = 0 To LBObj.ListCount - 1
                If AttRefObjs(i).TagString = LBObj.List(j) And LBObj.Selected(j) = True Then
                    If n = 1 Then
                        ' 首行，标签做为表格的列标题
                        xlSheet.Cells(n, j + 1).Value = AttRefObjs(i).TagString
                        xlSheet.Cells(n + 1, j + 1).Value = AttRefObjs(i).TextString
                    Else
                        xlSheet.Cells(n + 1, j + 1).Value = AttRefObjs(i).TextString
                    End If
                End If
            Next
        Next
    Next

    ' 删除表格中的空列
    For i = LBObj.ListCount - 1 To 0 Step -1
        If xlSheet.Cells(1, i + 1).Value = "" Then
            xlSheet.Columns(i + 1).Delete
        End If
    Next

    ' 按序号排序
    xlSheet.UsedRange.Sort Key1:=Range("A2"), Header:=xlYes
    ' 自动调整列宽
    xlSheet.Columns.AutoFit

    ' 释放Exccel对象
    Set xlSheet = Nothing
    Set xlBook = Nothing
    Set xlApp = Nothing
    Exit Sub

ErrTrap:
    On Error GoTo 0
End Sub

Excel VBA 范例文件代码

兰州人 · 发表于 2007-12-5 15:43:00

本帖最后由作者于 2007-12-9 21:37:01 编辑

select选择集+图层Layer

Sub ls()
Dim ss1 As AcadSelectionSet
Dim layername As String
Dim AcadEnt As AcadEntity
'Dim pp1 As AcadPoint, pp2 As AcadPoint
'指定图层名称
'Set pp1 = ThisDrawing.Utility.GetPoint
'Set pp2 = ThisDrawing.Utility.GetPoint
layername = "件号"
Dim tt As AcadText, MTt As AcadMText
'得到选择集

Dim gpCode(0) As Integer
Dim dataValue(0) As Variant
gpCode(0) = 8
dataValue(0) = layername

Set ss1 = ThisDrawing.SelectionSets.Add("ss3")
ss1.Select acSelectionSetAll, , , gpCode, dataValue
'ss1.Select acSelectionSetCrossing, pp1, pp2, , dataValue
For Each AcadEnt In ss1
'Debug.Print AcadEnt.ObjectName
Select Case AcadEnt.ObjectName
    Case "AcDbText"
      Set tt = AcadEnt
      Debug.Print tt.TextString
    Case "AcDbMText"
      Set MTt = AcadEnt
      Debug.Print "MText---", MTt.TextString
End Select
Next
ss1.Delete
'ss1.Clear
End Sub

muzi2005888 · 发表于 2007-12-30 16:32:00

支持兰州人！

zy19860604 · 发表于 2008-1-13 12:32:00

好资料

sooma · 发表于 2008-1-31 22:46:00

高人阿！谢谢

sunny2008 · 发表于 2008-2-25 19:01:00

收获了很多资料

ecepdiky · 发表于 2008-4-2 20:36:00

本人前不久也刚刚编写了一个cad表格自动输出到EXCEL的vba代码,基本思路就是把选择到的所有文字实体先按y坐标排序,由此可以把这些字分成若干行,每行再按纵坐标排序,确定先后顺序,缺点就是无法判断空的单元格,会导致后面的单元格内容串列.

wamjsq · 发表于 2009-12-12 10:39:00

很好的资料，学习，收藏

账号		自动登录	找回密码
密码			注册

[原创]Auto CAD材料一览表数据到Excel

本帖子中包含更多资源

评分

本帖子中包含更多资源

本帖子中包含更多资源

本帖子中包含更多资源