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帮助文件. ADO.rar
2008-7-23
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
' 释放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
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
置顶卡
请点击此处下载
