|
|
下面我的代码怎么总是有错误?
读取不了集合里的图元,不知道问题出在那?请高手指点
Private Sub CommandButton3_Click()
Dim sjk As New ADODB.Connection
Dim dw As New ADODB.Recordset
Dim text As New ADODB.Recordset
Dim ty As New ADODB.Recordset
Dim tylj As New ADODB.Recordset
Dim point As New ADODB.Recordset
Dim pointtext As New ADODB.Recordset
Dim sjklj, dwname As String
Dim x, y As Double
Dim tylx As String
sjklj = "Provider=MSDASQL.1ersist Security Info=False;Data Source=hbcad"
sjk.Open sjklj '打开库连接
dwname = InputBox("请输入单位名称")
ty.Open "select * from tysx where dwid in (select dwid from tyname where dwname='" & dwname & "')", sjk, adOpenDynamic, adLockBatchOptimistic
If ty.EOF Then
MsgBox ("库中没有此单位")
End
End If
Do While Not ty.EOF
tc = ty.Fields("larer") '图层
tylj.Open "select * from tylj where tyid=" & ty.Fields("cadid") & " order by xh asc", sjk, adOpenDynamic, adLockBatchOptimistic
tylx = ty.Fields("tylx") '图元类型
If tylx = "AcDbMText" Or tylx = "AcDbText" Then
te ty.Fields("cadid"), ty.Fields("larer"), sjk '注记
End If
Do While Not tylj.EOF
point.Open "select *from point where pointid=" & tylj.Fields("pointid") & " ", sjk, adOpenDynamic, adLockBatchOptimistic
Select Case tylx
Case "AcDbPolyline" '是多段线时
ThisDrawing.SendCommand "_pline" & vbCr
x = point.Fields("x")
y = point.Fields("y")
ThisDrawing.SendCommand x & "," & y & vbCr
Case "AcDbLine" '是line线时
ThisDrawing.SendCommand "_line" & vbCr
x = point.Fields("x")
y = point.Fields("y")
ThisDrawing.SendCommand x & "," & y & vbCr
End Select
tylj.MoveNext
point.Close
Loop
If tylx = "AcDbPolyline" Then
ThisDrawing.SendCommand "c" & vbCr
Else
If tylx = "AcDbLine" Then
ThisDrawing.SendCommand "" & vbCr
End If
End If
tjkzsj ty.Fields("cadid"), dwname, tc
tylj.Close
ty.MoveNext
Loop
ty.Close
MsgBox ("数据下载完毕")
End Sub
Private Sub te(cadid, tc, sjk) '下载注记
Dim text As New ADODB.Recordset
Dim pointtext As New ADODB.Recordset
text.Open "select * from tytext where cadid=" & cadid & "", sjk, adOpenDynamic, adLockBatchOptimistic
pointtext.Open "select *from point where pointid in (select pointid from tytext where cadid=" & cadid & ")", sjk, adOpenDynamic, adLockBatchOptimistic
ThisDrawing.SendCommand "_text" & vbCr
ThisDrawing.SendCommand pointtext.Fields("x") & "," & pointtext.Fields("y") & vbCr
ThisDrawing.SendCommand text.Fields("ztdx") & vbCr
ThisDrawing.SendCommand 0 & vbCr
ThisDrawing.SendCommand text.Fields("nr") & vbCr
ThisDrawing.SendCommand "" & vbCr
text.Close
pointtext.Close
End Sub
Private Sub tjkzsj(cadid, dwname, tc) '将新增的图元添加上扩展数据
wj = "d:\a.txt"
Open wj For Append As #1
Dim ty As AcadEntity
Dim layer As AcadLayer
Set layer = ThisDrawing.Layers.Add(tc)
Dim i As Long
i = ThisDrawing.ModelSpace.Count - 1;为什么我的i值总是-1呀!cad里明明有图元的呀
Set ty = ThisDrawing.ModelSpace.Item(i)
'Dim ssget As AcadSelectionSet
'On Error Resume Next
'If Not IsNull(ThisDrawing.SelectionSets.Item("xzj")) Then
'Set ssget = ThisDrawing.SelectionSets.Item("xzj")
'ssget.Delete
'End If
'Set ssget = ThisDrawing.SelectionSets.Add("xzj")
'ssget.Select acSelectionSetLast
'For Each ty In ssget
ty.layer = tc
ty.Update
Dim datatype(0 To 7) As Integer
Dim data(0 To 7) As Variant
datatype(0) = 1001: data(0) = "xdata"
datatype(1) = 1000: data(1) = dwname
datatype(2) = 1003: data(2) = "0"
datatype(3) = 1040: data(3) = 1.232
datatype(4) = 1041: data(4) = cadid
datatype(5) = 1070: data(5) = 5656
datatype(6) = 1071: data(6) = 32332
datatype(7) = 1042: data(7) = 10
ty.SetXData datatype, data
ThisDrawing.Application.Update
Dim xtype As Variant
Dim xdata As Variant
ty.GetXData "", xtpye, xdata
Write #1, tc, xdata(4)
'Next ty
'Write #1, tc, xdata(4)
Close #1
'kckzsj ty
'ssget.Delete
End Sub |
|
置顶卡
