标题: 我这段程序《要求对象的错误》怎么改啊 谢谢哈 [打印本页] 作者: z289449174 时间: 2009-5-23 20:35 标题: 我这段程序《要求对象的错误》怎么改啊 谢谢哈 Public Sub CreateConnection()
Dim Constr As String
Set cn = New ADODB.Connection
cn.CursorLocation = adUseClient
cn.Provider = "Microsoft.jet.OLEDB.4.0;"
Constr = "Data Source =D:\cad.mdb;"
cn.Open Constr
MsgBox "已经创建了一个到D:\cad.mdb的连接"
End Sub
Public Function HasTable(cn As ADODB.Connection, inputstr As String) As Boolean
Dim rst As New ADODB.Recordset
Set rst = cn.OpenSchema(adSchemaTables)
Dim i As Integer
For i = 0 To rst.RecordCount - 1
If UCase(rst.Fields("TABLE_NAME")) = UCase(IputStr) Then
HasTable = True
rst.Close
Exit Function
End If
rst.MoveNext
Next i
HasTable = False
rst.Close
End Function
Private Function FindObj(rst As ADODB.Recordset, ID As String) As Boolean
If rst.RecordCount > 0 Then
rst.MoveFirst
While Not rst.EOF
If Trim(rst.Fields("id")) = ID Then
FindObj = True
Exit Function
End If
rst.MoveNext
Wend
FindObj = False
Else
FindObj = False
End If
End Function
Public Sub AcadWriteToDB()
Dim cmd As ADODB.Command
Dim rst As ADODB.Recordset
Call CreateConnection
Set cmd = New ADODB.Command
Set cmd.ActiveConnection = cn
If HasTable((cn), "line") = False Then
cmd.CommandText = "CREATE TABLE Line(id char(10),X1 float,Y1 float,X2 float,Y2 float);"
cmd.Execute
End If
If HasTable((cn), "circle") = False Then
cmd.CommandText = "CREATE TABLE circle(id char(10),CenX float,CenY float,Rad float);"
cmd.Execute
End If
If HasTable((cn), "arc") = False Then
cmd.CommandText = "CREATE TABLE arc(id char(10),CenX float,CenY float,Rad float," & "StartAng float,EndAng float);"
cmd.Execute
End If
Set rst = New ADODB.Recordset
rst.CursorLocation = adUseClient
Dim pt1 As Variant, pt2 As Variant
Dim obj As AcadEntity
For Each obj In ThisDrawing.ModelSpace
Select Case obj.ObjectName
Case "acdbline":
rst.Open "SELECT id FORM line", cn, adOpenForwardOnly, adLockReadOnly, adCmdText
pt1 = obj.StarPoint
pt2 = obj.EndPoint
If Not FindObj((rst), obj.ObjectID) Then
cmd.CommandText = "INSERT INTO line(id,X1,Y1,X2,Y2)VALUES(" & "'" & obj.ObjectID & "','" & pt1(0) & "','" & pt1(1) & "'," & pt2(0) & "," & pt2(1) & ");"
Else
cmd.CommandText = "UPDATE line SET X1 = " & pt1(0) & ",Y1 = " & pt1(1) & ",X2 = " & pt2(0) & ",Y2 = " & pt2(1) & "WHERE id = '" & obj.ObjectID & "';"
End If
cmd.Execute
rst.Close
Case "acdbcircle":
rst.Open "SELECT id FORM circle", cn, adOpenForwardOnly, adLockReadOnly, adCmdText
pt1 = obj.Center
If Not FindObj((rst), obj.ObjectID) Then
cmd.CommandText = "insert into circle(id,cenx,ceny,rad)values('" & obj.ObjectID & "'," & "'" & pt1(0) & "','" & pt1(1) & "','" & obj.Radius & "' , ) ; "
Else
cmd.CommandText = "UPDATE circle SET CenX =" & pt1(0) & ",CenY = " & pt1(1) & ",Rad = " & obj.Radius & "WHERE id = '" & obj.ObjectID & "';"
End If
cmd.Execute
rst.Close
Case "AcDbArc":
rst.Open "SELECT id FORM arc", cn, adOpenForwardOnly, adLockReadOnly, adCmdText
pt1 = obj.Center
If Not FindObj((rst), obj.ObjectID) Then
cmd.CommandText = "INSERT INTO arc(id,CenX,CenY,Rad,StartAng,EndAng)VALUES('" & obj.ObjectID & "'," & " '" & pt1(0) & "','" & pt1(1) & "','" & obj.Radius & "','" & obj.StartAngle & "','" & obj.EndAngle & "' ) ; "
Else