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

laoxie_1983

CAD图形也可以写到SQL数据库里，客户端的用户就可以从数据库里下载数据生成图形。
这样就实现了cad图形的网络化管理。

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

左权

好啊，这个程序真是是好啊！！我喜欢!

ps122

辛苦，学习中

zcmjw

学习中

cgh93001

好东东 值得学习研究

laoxie_1983

不足之处请指出.

peggylau

学习

yagoole

谢谢，楼主好强！ ；）

bashen5282

很不错哦~~~~~

poiwer

没人气...............................

lin-bo-ying

不错

lapack

学习学习

phi03c

wonderfull thanks