|
|
Sub xz(dww)
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 tyname As New Recordset
Dim tylj As New ADODB.Recordset
Dim point As New ADODB.Recordset
Dim pointtext As New ADODB.Recordset
Dim sjklj, dwname, dwlj, yhm, tc, tc1, bh, tyxx As String
yhm = "002"
Dim x, y As Double
Dim tylx As String
sjklj = "Provider=MSDASQL.1ersist Security Info=False;Data Source=hbcad"
sjk.Open sjklj '打开库连接
'dwname = InputBox("请输入单位名称")
dwzfcd = Len(dww)
dwname = Trim(dww)
dwlj = "select * from tyname where dwname = '" & dwname & "'"
tyname.Open dwlj, sjk, adOpenDynamic, adLockBatchOptimistic
If tyname.EOF Then
MsgBox ("库中无此单位信息")
End
Else
If tyname.Fields("sm") = "002" Then
MsgBox ("本图形已经有用户使用")
End
Else
ty.Open "select * from tysx where dwid in (select dwid from tyname where dwname like '%" & dwname & "%'and sm'002' )", sjk, adOpenDynamic, adLockBatchOptimistic
Dim w As Double
w = 1
Do While Not ty.EOF
tyxx = ty.Fields("linetype") '线性
tjxx (tyxx)
tylx = ty.Fields("tylx") '图元类型
bh = ty.Fields("is")
tc = ty.Fields("larer") '图层
If tylx = "AcDbMText" Or tylx = "AcDbText" Then
te ty.Fields("cadid"), ty.Fields("larer"), sjk '注记
End If
tylj.Open "select * from tylj where tyid=" & ty.Fields("cadid") & " order by xh asc", sjk, adOpenDynamic, adLockBatchOptimistic
Do While Not tylj.EOF
point.Open "select *from point where pointid=" & tylj.Fields("pointid") & " ", sjk, adOpenDynamic, adLockBatchOptimistic
Select Case tylx
'Case "AcDbMText" Or "AcDbText"
'te ty.Fields("cadid"), ty.Fields("larer"), sjk '注记
Case "AcDbPolyline" '是多段线时
'Dim ewlayer As AcadLayer
'Set ewlayer = ThisDrawing.Layers.Add(tc)
'ThisDrawing.ActiveLayer = ewlayer
ThisDrawing.SendCommand "_pline" & vbCr
x = point.Fields("x")
y = point.Fields("y")
ThisDrawing.SendCommand x & "," & y & vbCr
Case "AcDbLine" '是line线时
'Dim wlayer As AcadLayer
'Set wlayer = ThisDrawing.Layers.Add(tc)
'ThisDrawing.ActiveLayer = wlayer
ThisDrawing.SendCommand "_line" & vbCr
x = point.Fields("x")
y = point.Fields("y")
ThisDrawing.SendCommand x & "," & y & vbCr
Case "AcDbBlockReference"
block point, sjk
End Select
tylj.MoveNext
point.Close
Loop
If tylx = "AcDbPolyline" Then
If bh = "1" Then
ThisDrawing.SendCommand "c" & vbCr
Else
ThisDrawing.SendCommand "" & vbCr
End If
Else
If tylx = "AcDbLine" Then
ThisDrawing.SendCommand "" & vbCr
End If
End If
Dim xzj As AcadSelectionSet
' If Not IsNull(ThisDrawing.SelectionSets.Item("s1")) Then
'Set xzj = ThisDrawing.SelectionSets.Item("s1")
'xzj.Delete
'End If
' Set xzj = ThisDrawing.SelectionSets.Add("s1")
' xzj.Select acSelectionSetLast
' Dim lr As AcadEntity
' For Each lr In xzj
'lr = xzj.Item(1)
'lr.layer = tc
'Next lr
tjkzsj ty.Fields("cadid"), dwname, tc
tylj.Close
ty.MoveNext
Loop
ty.Close
End If
End If
sjk.Execute "update tyname set sm='" & yhm & "' where dwname like '%" & dwname & "%'"
MsgBox ("数据下载完毕")
sjk.Close
End
End Sub
Private Sub block(point, cn) '插入块
Dim blockobject As AcadBlock
Dim ljj As New ADODB.Recordset
Dim blockname As String
Dim zb(0 To 2) As Variant
ljj.Open "select * from block where cadid in (select tyid from tylj where pointid= " & point.Fields("pointid") & ")", cn, adOpenDynamic, adLockBatchOptimistic
If Not ljj.EOF Then
blockname = ljj.Fields("name")
zb(0) = point.Fields("x")
zb(1) = point.Fields("Y")
zb(2) = 0
'Set bolckobject = ThisDrawing.ModelSpace.InsertBlock(zb, blockname, 1, 1, 1, 0)
'ThisDrawing.ModelSpace.InsertBlock zb, blockname, ljj.Fields("xs"), ljj.Fields("ys"), ljj.Fields("zs"), 1
'ThisDrawing.SendCommand "-insert" & vbCr
ThisDrawing.SendCommand "-insert" & vbCr & blockname & vbCr & point.Fields("x") & "," & point.Fields("y") & vbCr & ljj.Fields("xs") & vbCr & ljj.Fields("ys") & vbCr & ljj.Fields("zs") & vbCr & ljj.Fields("jd") & vbCr
'ThisDrawing.SendCommand blockname & vbCr
'ThisDrawing.SendCommand point.Fields("y") & "," & point.Fields("x") & vbCr
'ThisDrawing.SendCommand ljj.Fields("xs") & vbCr
' ThisDrawing.SendCommand ljj.Fields("ys") & vbCr
' ThisDrawing.SendCommand ljj.Fields("zs") & vbCr
'ThisDrawing.SendCommand 0 & vbCr
'ThisDrawing.SendCommand "" & vbCr
End If
ljj.Close
End Sub
Private Sub te(cadid, tc, sjk) '下载注记
Dim jdzh As Double
Dim newlayer As AcadLayer
Set newlayer = ThisDrawing.Layers.Add(tc)
ThisDrawing.ActiveLayer = newlayer
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
jdzh = text.Fields("zjjd") / 0.017453292 '注记角度
ThisDrawing.SendCommand "_text" & vbCr
ThisDrawing.SendCommand pointtext.Fields("x") & "," & pointtext.Fields("y") & vbCr
ThisDrawing.SendCommand text.Fields("ztdx") & vbCr
ThisDrawing.SendCommand jdzh & vbCr
ThisDrawing.SendCommand text.Fields("nr") & vbCr
ThisDrawing.SendCommand "" & vbCr
text.Close
pointtext.Close
End Sub
Private Sub tjkzsj(cadid, dwname, tc) '将新增的图元添加上扩展数据
'On Error Resume Next
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
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
Private Sub kckzsj(ty As AcadEntity)
Dim xtype As Variant
Dim xdata As Variant
ty.GetXData "", xtpye, xdata
End Sub
Private Sub tjtc(t As String)
Dim wlayer As AcadLayer
Set wlayer = ThisDrawing.Layers.Add(t)
ThisDrawing.ActiveLayer = wlayer
'Dim aa As AcadEntity
'Dim ly As AcadLayer
'Set ly = ThisDrawing.Layers.Add(t)
'Dim ll As String
'Dim l As Integer
'i = ThisDrawing.ModelSpace.Count - 1
'If i
End Sub |
|
置顶卡
