[求助]：再求高手相助

laoxie_1983

下面我的代码怎么总是有错误?

读取不了集合里的图元,不知道问题出在那?请高手指点



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.1;Persist 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