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

laoxie_198

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.1ersist 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 Sub

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

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

End 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.29578049

l = 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.Close

End 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

好的，学习学习。

laoxie_198

不足的地方请指出

chengdd

谢谢你分享！

autocadvba

多谢您提供的宝贵代码！

laoxie_198

大家互相学习吗？

xiangyu1983

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

laoxie_198

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

xiangyu1983

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

    写在同一表不混乱，且避免重复建表的麻烦。使数据库维护和查询更方便。

laoxie_198

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