[原创]从SQL数据库中提取数据生成CAD图形

laoxie_198 发表于 2007-10-23 19:45:00

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.1;Persist 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.CloseEnd 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 SubPrivate 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 < 0 Then 'i = 0 'End If 'Set aa = ThisDrawing.ModelSpace.Item(i) 'll = aa.layer 'aa.layer = t 'MsgBox (ll) End Sub Private Sub tjxx(t As String) t = Trim(t) 'ThisDrawing.SendCommand "_linetype" & vbCr & s & vbCr & t & vbCr & "" & vbCr & "" & vbCr     'ThisDrawing.SendCommand "s" & vbCr     'ThisDrawing.SendCommand t & vbCr     'ThisDrawing.SendCommand "" & vbCr ThisDrawing.ActiveLinetype = ThisDrawing.Linetypes.Item(t)End Sub

页: [1]

明经CAD社区's Archiver

[原创]从SQL数据库中提取数据生成CAD图形