再求高手帮忙!!

laoxie_198 发表于 2006-11-24 11:02:00

下面我的代码怎么总是有错误?
读取不了集合里的图元,不知道问题出在那?请高手指点

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

页: [1]

明经CAD社区's Archiver

再求高手帮忙!!