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

laoxie_198

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 < 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