[原创]cad图形写入SQL数据库实例

laoxie_198 发表于 2007-6-15 17:44:00

Sub sc() Dim dwname, tymc As String Dim cn As New ADODB.Connection Dim rst As New ADODB.Recordset Dim poin As New ADODB.Recordset Dim tyl As New ADODB.Recordset Dim block As New ADODB.Recordset 'block表处理 Dim klj, blj, lx, point, tylj, yhmm As String yhmm = "" Dim tysx As String Dim id, cadid, js, bh, dwsm, tyidh As Long Dim mytime As Date Dim mj As Double Dim dds, mm As Integer '图元计算 dds = 0 mm = 0 Dim plzb As Variant '顶点坐标数组 mytime = CDate(Date) Dim ob As AcadEntity For Each ob In ThisDrawing.ModelSpace If ob.layer = "图形单位名称" Then   txmc = Trim$(ob.TextString)   z = InStr(txmc, ";")   tymc = Mid$(txmc, z + 1, (Len(txmc) - z))   If Right$(tymc, 1) = "}" Then   tymc = Mid$(tymc, 1, (Len(tymc) - 1))   End If   End If Next ob If tymc <> "" Then dwname = tymc point = "select * from point order by pointid desc" tylj = "select * from tylj where tyid in (select cadid from tysx where dwid in (select dwid from tyname where dwname=" & dwname & "))" blj = "select * from tysx where dwid in (select dwid from tyname where dwname= '" & dwname & "')" 'klj = "provider=sqloledb.1;password=;persist security info=true;user id=sa;initial catalog=cad ;data source=huangbin" '库连接字符串 klj = "Provider=MSDASQL.1;Persist Security Info=False;Data Source=hbcad" cn.Open klj '连接数据库 dwsm = 0 rst.Open "select * from tyname order by dwid desc", cn, adOpenDynamic, adLockBatchOptimistic Do While Not rst.EOF   dwsm = rst.Fields("dwid")  '统计单位数目最大号   GoTo 2   'rst.MoveNext Loop 2: rst.Close rst.Open "select * from tyname where dwname='" & dwname & "'", cn, adOpenDynamic, adLockBatchOptimistic If rst.EOF Then   mm = mm + 1   cn.Execute "insert into tyname values(" & dwsm + 1 & ",'" & dwname & "','', " & mytime & ")"   Else   yhm = Trim(rst.Fields("sm"))   If yhm = "" Then    MsgBox "数据已经上传"    End   End If End If rst.Close Dim obj As AcadEntity Dim obj1 As AcadEntity Dim obj2 As AcadEntity Dim obj3 As AcadEntity Dim obj4 As AcadEntity Dim obj5 As AcadEntity 'text Dim obj6 As AcadEntity Dim obj7 As AcadEntity 'rst.Open blj, cn, adOpenDynamic, adLockBatchOptimistic '----------以下删除库中多余的图元信息 rst.Open blj, cn, adOpenDynamic, adLockBatchOptimistic kzsj obj, cn, dwname '将所有图元添加扩展数据 findid dwname, cn cn.Execute "delete tylj from tylj where tyid not in (select cadid from tysx)" cn.Close '----------以上删除库中多余的图元信息 For Each obj In ThisDrawing.ModelSpace cn.Open klj ' Dim xtype As Variant Dim xdata As Variant obj.GetXData "", xtpye, xdata tyidh = xdata(4)Set obj1 = obj Set obj2 = obj Set obj3 = obj Set obj4 = obj Set obj5 = obj Set obj6 = obj dds = dds + 1 '图元统计 tysx = obj.ObjectName Dim i As Integer     rst.Open "select * from tysx where  cadid =" & tyidh & "", cn, adOpenStatic, adLockReadOnly     If Not rst.EOF Then     id = rst.Fields("cadid")     cadid = rst.Fields("cadid")     End If     rst.Close     rst.Open "select * from tysx", cn, adOpenDynamic, adLockBatchOptimistic     If cadid = xdata(4) Then '图元修改     cn.Execute "update tysx set time=" & mytime & " where cadid=" & tyidh & ""     poin.Open point, cn, adOpenDynamic, adLockBatchOptimistic '打开point表连接        Select Case tysx        Case "AcDbPolyline": '是pl线时        xgpline poin, rst, tylj, obj3, cn, xdata(4) '将值插入到tylj表中        Case "AcDbLine": '是l线时        xgli poin, rst, tylj, obj4, cn, xdata(4) '将值插入到point表中        Case "AcDbMText"        mytex poin, tylj, obj6, cn, xdata(4)        Case "AcDbText"        ytex poin, tylj, obj6, cn, xdata(4)        Case "AcDbBlockReference" '块        blockxg point, tylj, obj, cn, xdata(4)     End Select     Else '图元新增     If mm = 1 Then       If obj.ObjectName = "AcDbPolyline" Then          If obj.Closed = "True" Then            cn.Execute "insert into tysx values (" & tyidh & ", '" & tysx & "', " & mytime & "," & dwsm + 1 & ",'" & obj.layer & "',1,'" & obj.Linetype & "','" & obj.color & "')"            Else            cn.Execute "insert into tysx values (" & tyidh & ", '" & tysx & "', " & mytime & "," & dwsm + 1 & ",'" & obj.layer & "',0 ,'" & obj.Linetype & "','" & obj.color & "')"          End If       Else        cn.Execute "insert into tysx values (" & tyidh & ", '" & tysx & "', " & mytime & "," & dwsm + 1 & ",'" & obj.layer & "',0 ,'" & obj.Linetype & "','" & obj.color & "')" '将图元信息插入tysx表中       End If     Else     If obj.ObjectName = "AcDbPolyline" Then          If obj.Closed = "True" Then            cn.Execute "insert into tysx values (" & tyidh & ", '" & tysx & "', " & mytime & "," & dwsm & ",'" & obj.layer & "',1,'" & obj.Linetype & "','" & obj.color & "')"            Else            cn.Execute "insert into tysx values (" & tyidh & ", '" & tysx & "', " & mytime & "," & dwsm & ",'" & obj.layer & "',0 ,'" & obj.Linetype & "','" & obj.color & "')"          End If       Else        cn.Execute "insert into tysx values (" & tyidh & ", '" & tysx & "', " & mytime & "," & dwsm & ",'" & obj.layer & "',0 ,'" & obj.Linetype & "')"  '将图元信息插入tysx表中       End If     End If     poin.Open point, cn, adOpenDynamic, adLockBatchOptimistic '打开point表连接     Select Case tysx        Case "AcDbPolyline": '是pl线时        pline poin, tylj, obj2, cn, tyidh '将值插入到tylj表中        Case "AcDbLine": '是l线时        li poin, tylj, obj1, cn, tyidh '将值插入到point表中        Case "AcDbMText" '新增text'         mtex poin, tylj, obj5, cn, tyidh         Case "AcDbText"         tex poin, tylj, obj5, cn, tyidh         Case "AcDbBlockReference" '块新增         blockadd point, tylj, obj, cn, tyidh         Case "AcDbPoint" '点         pointad point, tylj, obj, cn, tyidh             End Select        End If    rst.Close  rst.Open blj, cn, adOpenDynamic, adLockBatchOptimistic  cn.Close Next obj 'MsgBox ("上传完毕") Else MsgBox ("没有单位名称") End End If cn.Open , klj cn.Execute "update tyname set sm='" & yhmm & "' where dwname like '%" & dwname & "%'" MsgBox ("数据上传完毕") cn.Close End End Sub Private Sub ytex(point, ty1, obj6 As AcadEntity, cn, tyidh) 'text修改 Dim zb As Variant Dim dh, zjjd As Double dh = 0 Dim ztgd As Double zjjd = obj6.Rotation ztgd = obj6.Height zb = obj6.InsertionPoint txmc = Trim$(obj6.TextString)   z = InStr(txmc, ";")   tymc = Mid$(txmc, z + 1, (Len(txmc) - z))     If Right$(tymc, 1) = "}" Then   tymc = Mid$(tymc, 1, (Len(tymc) - 1))   End If cn.Execute "update point set x=" & zb(0) & ",y=" & zb(1) & " from point where pointid in (select pointid from tytext where cadid=" & tyidh & " )" cn.Execute "update tytext set nr='" & tymc & "',layer='" & obj6.layer & "',ztdx=" & ztgd & " ,zjjd= " & zjjd & "from tytext where cadid=" & tyidh & "" cn.Execute "update tysx set color='" & obj6.color & "' from tysx where cadid=" & tyidh & ""End Sub Private Sub mytex(point, ty1, obj As AcadEntity, cn, tyidh) '多行文字修改 Dim zb As Variant Dim dh, zjjd As Double Dim width As DataTypeEnum dh = 0 Dim ztgd As Double width = obj.width zjjd = obj.Rotation ztgd = obj.Height zb = obj.InsertionPoint txmc = Trim$(obj.TextString)   z = InStr(txmc, ";")   tymc = Mid$(txmc, z + 1, (Len(txmc) - z))     If Right$(tymc, 1) = "}" Then   tymc = Mid$(tymc, 1, (Len(tymc) - 1))   End If cn.Execute "update point set x=" & zb(0) & ",y=" & zb(1) & " from point where pointid in (select pointid from tytext where cadid=" & tyidh & " )" cn.Execute "update tytext set nr='" & tymc & "',layer='" & obj.layer & "',ztdx=" & ztgd & " ,zjjd= " & zjjd & " , width =" & width & " from tytext where cadid=" & tyidh & "" cn.Execute "update tysx set color='" & obj6.color & "' from tysx where cadid=" & tyidh & "" End SubPrivate Sub tex(point, ty1, obj5 As AcadEntity, cn, tyidh)  'text新增 Dim ztgd, zjjd As Double Dim wjwidth As Double ztgd = obj5.Height Dim zb As Variant Dim dh, ydh As Double dh = 0 Dim pt As New ADODB.Recordset pt.Open "select * from point order by pointid desc", cn, adOpenDynamic, adLockBatchOptimistic If Not pt.EOF Then    dh = pt.Fields("pointid") End If '计算点总数 pt.Close zb = obj5.InsertionPoint zjjd = obj5.Rotation txmc = Trim$(obj5.TextString)   z = InStr(txmc, ";")   tymc = Mid$(txmc, z + 1, (Len(txmc) - z))     If Right$(tymc, 1) = "}" Then   tymc = Mid$(tymc, 1, (Len(tymc) - 1))   End If   cn.Execute "insert into tylj values( " & tyidh & ",1," & dh + 1 & ")" '图元连接 pt.Open "select *from point where x=" & zb(0) & " and y=" & zb(0) & " ", cn, adOpenDynamic, adLockBatchOptimistic If Not pt.EOF Then   ydh = pt.Fields("pointid")   cn.Execute "insert into tytext values(" & tyidh & ",'" & tymc & "','" & obj5.layer & "'," & ztgd & ",ydh, " & zjjd & ")" '角度   Else   cn.Execute "insert into tytext values(" & tyidh & ",'" & tymc & "','" & obj5.layer & "'," & ztgd & "," & dh + 1 & ", " & zjjd & " ,0)"   cn.Execute "insert into point values( " & dh + 1 & ",'' ," & zb(0) & "," & zb(1) & ",'')" End IfEnd Sub Private Sub mtex(point, ty1, obj As AcadEntity, cn, tyidh) '多行文字新增 Dim ztgd, zjjd As Double Dim wjwidth As Double ztgd = obj.Height Dim zb As Variant Dim dh, ydh As Double dh = 0 Dim pt As New ADODB.Recordset pt.Open "select * from point order by pointid desc", cn, adOpenDynamic, adLockBatchOptimistic If Not pt.EOF Then    dh = pt.Fields("pointid") End If '计算点总数 pt.Close wjwidth = obj.width zb = obj.InsertionPoint zjjd = obj.Rotation txmc = Trim$(obj.TextString)   z = InStr(txmc, ";")   tymc = Mid$(txmc, z + 1, (Len(txmc) - z))     If Right$(tymc, 1) = "}" Then   tymc = Mid$(tymc, 1, (Len(tymc) - 1))   End If   cn.Execute "insert into tylj values( " & tyidh & ",1," & dh + 1 & ")" '图元连接 pt.Open "select *from point where x=" & zb(0) & " and y=" & zb(0) & " ", cn, adOpenDynamic, adLockBatchOptimistic If Not pt.EOF Then   ydh = pt.Fields("pointid")   cn.Execute "insert into tytext values(" & tyidh & ",'" & tymc & "','" & obj.layer & "'," & ztgd & ",ydh, " & zjjd & "," & wjwidth & ")" '角度   Else   cn.Execute "insert into tytext values(" & tyidh & ",'" & tymc & "','" & obj.layer & "'," & ztgd & "," & dh + 1 & ", " & zjjd & " ," & wjwidth & ")"   cn.Execute "insert into point values( " & dh + 1 & ",'' ," & zb(0) & "," & zb(1) & ",'')" End IfEnd Sub Private Sub xgpline(point, rst, ty1, obj3 As AcadEntity, cn, tyidh) '原有pl线处理过程 Dim plzb As Variant '顶点坐标数组 Dim ss, dh As Integer Dim js As Integer Dim sql As String js = 0 dh = 1 Dim xw As New ADODB.Recordset sql = "select qq=sum(pointid) from point where pointid in (select pointid from tylj where tyid =" & tyidh & ") " xw.Open sql, cn, adOpenDynamic, adLockBatchOptimistic Do While Not xw.EOF '判断数据库里点数  js = xw.Fields("qq")  GoTo 4  'xw.MoveNext  Loop 4:  plzb = obj3.Coordinates   ss = (UBound(plzb) + 1) / 2 '图形中本图元点数   If js = ss Then   Dim zb As Variant   For i = 0 To ss - 1    zb = obj3.Coordinate(i) '单个点坐标    cn.Execute "update point set x=" & zb(0) & ",y=" & zb(1) & " from point where pointid in (select pointid from tylj where tyid=" & tyidh & " and xh=" & dh & ")"    dh = dh + 1   Next i   End If   point.Close  End Sub Private Sub xgli(point, rst, tyl, obj4 As AcadEntity, cn, tyidh) '原有line线处理 Dim i As Integer i = 0 Dim pt1 As Variant Dim pt2 As Variant pt1 = obj4.StartPoint pt2 = obj4.EndPoint cn.Execute "update point set x=" & pt1(0) & ",y=" & pt1(1) & " from point where pointid in (select pointid from tylj where tyid=" & tyidh & " and xh=1)" cn.Execute "update point set x=" & pt2(0) & ",y=" & pt2(1) & " from point where pointid in (select pointid from tylj where tyid=" & tyidh & " and xh=2)" End Sub Private Sub blockxg(point, ty1, obj As AcadEntity, cn, tyidh) '原有块处理 Dim zb As Variant Dim x, y, z As Integer Dim jd As Double Dim blockname As String x = obj.XScaleFactor y = obj.YScaleFactor z = obj.Zsxalefactor zb = obj.InsertionPoint jd = obj.Rotation * 57.28970065 blockname = obj.name cn.Execute "update point set x=" & zb(0) & ",y=" & zb(1) & " from point where pointid in (select pointid from tylj where tyid=" & tyidh & ")" cn.Execute "update block set xs=" & x & " ,yx= " & y & ", zs=" & z & " ,jd=" & jd & "　from block where cadid=" & tyidh & "" End Sub Private Sub blockadd(point, ty1, obj As AcadEntity, cn, tyidh) '新增块处理 Dim block As New ADODB.Recordset Dim zb As Variant Dim dh, x, y, z As Integer Dim crjd As Double '插入角度 x = obj.XScaleFactor y = obj.YScaleFactor z = obj.ZScaleFactor zb = obj.InsertionPoint crjd = obj.Rotation * 57.29578049l = 1 blockname = obj.name block.Open "select pointid from point order by pointid desc", cn, adOpenDynamic, adLockBatchOptimistic If Not block.EOF Then dh = block.Fields("pointid") Else dh = 0 End If cn.Execute "insert into tylj values( " & tyidh & ",1," & dh + 1 & ")" '图元连接 cn.Execute "insert into point values( " & dh + 1 & ",'' ," & zb(0) & "," & zb(1) & ",'')" '点表 cn.Execute "insert into block values(" & tyidh & " ,'" & blockname & " '," & x & "," & y & ", " & z & " ," & crjd & "," & dh + 1 & ") " '块属性。 End Sub Private Sub pointad(point, ty, obj As AcadEntity, cn, tyidh) '新增点的处理 Dim zb As Variant Dim po As New ADODB.Recordset po.Open "select * from point order by pointid desc", cn, adOpenDynamic, adLockBatchOptimistic If Not po.EOF Then  dh = po.Fields("pointid")  Else  dh = 0  End If  po.Close   zb = obj.Coordinates cn.Execute "insert into tylj values( " & tyidh & ",1," & dh + 1 & ")" '图元连接 cn.Execute "insert into point values( " & dh + 1 & ",'' ," & zb(0) & "," & zb(1) & ",'')" '点表 End Sub Private Sub pline(point, tyl, obj2 As AcadEntity, cn, tyidh) '新建pl线处理过程 Dim mx As New ADODB.Recordset   Dim plzb As Variant '顶点坐标数组   Dim ss, dh As Integer   dh = 0   Do While Not point.EOF    'dh = dh + 1    dh = point.Fields("pointid")    GoTo l   Loop l:  plzb = obj2.Coordinates   ss = (UBound(plzb) + 1) / 2   Dim zb As Variant   For i = 0 To ss - 1    zb = obj2.Coordinate(i) '单个点坐标    mx.Open "select * from point where x=" & zb(0) & " and y=" & zb(1) & "", cn, adOpenDynamic, adLockBatchOptimistic    If Not mx.EOF Then     cn.Execute "insert into tylj values( " & tyidh & "," & i + 1 & "," & mx.Fields("pointid") & ")"     Else    cn.Execute "insert into tylj values( " & tyidh & "," & i + 1 & "," & dh + 1 & ")"    cn.Execute "insert into point values( " & dh + 1 & ",'' ," & zb(0) & "," & zb(1) & ",'')"    dh = dh + 1    End If    mx.Close   Next i   point.Close End Sub Private Sub li(poin, tyl, obj1 As AcadEntity, cn, tyidh) '新建line线处理 Dim mx As New ADODB.Recordset Dim i, j, s As Integer i = 0 Dim pt1 As Variant Dim pt2 As Variant pt1 = obj1.StartPoint pt2 = obj1.EndPoint Do While Not poin.EOF i = poin.Fields("pointid")  'i = i + 1  GoTo q  'poin.MoveNext  Loop '计算点数 q: mx.Open "select * from point where x=" & pt1(0) & " and y=" & pt1(1) & "", cn, adOpenDynamic, adLockBatchOptimistic  If Not mx.EOF Then    cn.Execute "insert into tylj values( " & tyidh & ",1," & mx.Fields("pointid") & ")"  Else  cn.Execute "insert into point values( " & i + 1 & ",'' ," & pt1(0) & "," & pt1(1) & ",'')"  cn.Execute "insert into tylj values( " & tyidh & ",1," & i + 1 & ")"  End If  mx.Close  i = i + 1  mx.Open "select * from point where x=" & pt2(0) & " and y=" & pt2(1) & "", cn, adOpenDynamic, adLockBatchOptimistic  If Not mx.EOF Then    cn.Execute "insert into tylj values(" & tyidh & ",2," & mx.Fields("pointid") & ")"    Else      cn.Execute "insert into point values( " & i + 1 & ",'' ," & pt2(0) & "," & pt2(1) & ",'')"      cn.Execute "insert into tylj values( " & tyidh & ",2," & i + 1 & ")"   End If  poin.Close  'tyl.CloseEnd Sub Private Sub kzsj(obj As AcadEntity, cn, dwname) '加扩展数据 wj = "d:\b.txt" Open wj For Append As #1 Dim sjk As New ADODB.Recordset Dim id As Long id = 0 sjk.Open "select * from tysx order by cadid desc ", cn, adOpenDynamic, adLockReadOnly Do While Not sjk.EOF   id = sjk.Fields("cadid")   GoTo w   'sjk.MoveNext Loop w: sjk.Close For Each obj In ThisDrawing.ModelSpace Dim xtype As Variant Dim xdata As Variant obj.GetXData "", xtpye, xdata If VarType(xdata) = 0 Then '判断是否有扩展数据。 Dim datatype(0 To 7) As Integer Dim data(0 To 7) As Variant datatype(0) = 1001: data(0) = "tete" datatype(1) = 1000: data(1) = dwname datatype(2) = 1003: data(2) = "0" datatype(3) = 1040: data(3) = 1.232 datatype(4) = 1041: data(4) = id + 1 datatype(5) = 1070: data(5) = 5656 datatype(6) = 1071: data(6) = 32332 datatype(7) = 1042: data(7) = 10 obj.SetXData datatype, data ThisDrawing.Application.Update id = id + 1 Write #1, data(4) End If Next obj Close #1 End Sub Private Function dqkzsj(obj As AcadEntity) '读取扩展数据 Dim id As Long Dim xtype As Variant Dim xdata As Variant obj.GetXData "", xtpye, xdata id = tyidh End Function'图形中删除图元时库中也删除。 Private Sub findid(dwname, cn) Dim js As Integer Dim id As Long Dim rst1 As New ADODB.Recordset rst1.Open "select * from tysx where dwid in (select dwid from tyname where dwname='" & dwname & "')", cn, adOpenDynamic, adLockBatchOptimistic   Do While Not rst1.EOF      js = 0      id = rst1.Fields("cadid")      For Each obj In ThisDrawing.ModelSpace      Dim xtype As Variant      Dim xdata As Variant      obj.GetXData "", xtpye, xdata        If id = xdata(4) Then        js = js + 1        End If        'cn.Execute "delete tytable where id= " & obj.ObjectID & ""      Next obj      If js = 0 Then      cn.Execute "delete tysx where cadid=" & rst1.Fields("cadid") & ""      End If      rst1.MoveNext    Loop rst1.Close          End Sub

tcsl9621 发表于 2007-6-15 23:24:00

好的，学习学习。

laoxie_198 发表于 2007-6-21 08:02:00

不足的地方请指出

chengdd 发表于 2007-6-27 22:32:00

谢谢你分享！

autocadvba 发表于 2007-7-17 17:54:00

多谢您提供的宝贵代码！

laoxie_198 发表于 2007-7-18 08:46:00

大家互相学习吗？

xiangyu1983 发表于 2007-8-22 20:13:00

程序还简洁，但数据库表太多，也不利于以后读取数据库信息再作图，实现网络协同。用一个表写入所有平面图形几何信息那就好了。

laoxie_198 发表于 2007-8-28 19:36:00

写到同一个表里,数据太混乱了.读取信息在作图的模块我已经写好了,感觉在图形数据很大的时候运行速度比较吗,正在想办法改进.还请高手们多多执教

xiangyu1983 发表于 2007-8-28 20:05:00

我论文的一部分正是在做这东西，  我思路是把二维图形信息入库，建了三个表，一个用于作图时读取数据用的，一个总表，是对所进行操作和所操作图形信息查询用的，  还有一个就是删除图形的表（避免画出重复的图）。   我可能是机子配置所限，在一次录入大量复杂图形信息时比较慢（例如一次录入很多复杂多段线）。在读取大量信息画图是还算快。    写在同一表不混乱，且避免重复建表的麻烦。使数据库维护和查询更方便。

laoxie_198 发表于 2007-9-1 19:14:00

谢谢楼上的朋友，我去试试将数据写在一个表里。不过感觉有点混乱了。

页: [1] 2

明经CAD社区's Archiver

[原创]cad图形写入SQL数据库实例