VBA数据库难题
大家好，在我们公司，我们使用autocad绘制管道仪表图。我们使用MS Acces（.mdb）文件作为每个图形中所有组件的数据库，因此我们可以制作各种项目列表。大多数信息都在块及其属性中。
目前。。一切正常。当我们向图形中添加某些内容时，会出现以下VBA；
Private Sub AcadDocument_ObjectAdded(ByVal Object As Object)
Dim G_tmp_db, G_name_add, G_blname, G_combbl As String
On Error GoTo Err_objera
Call G_frmt_chk
G_tmp_db = Left(G_dwg_path, (Len(G_dwg_path) - 4)) & "_tmpblk"
G_name_add = Mid(TypeName(Object), 2)
Set dbblock = opendatabase(G_tmp_db)
Set rsblock = dbblock.OpenRecordset("Blocks", dbOpenTable)
If (G_name_add = "AcadBlockReference") Then
If ((Left(Object.Name, 3) = "G_B") Or (Left(Object.Name, 3) = "G_E") Or _
(Left(Object.Name, 3) = "G_I") Or (Left(Object.Name, 3) = "G_A")) Then
rsblock.AddNew
rsblock("ObjectID") = Object.ObjectID
rsblock("Handle") = Object.Handle
rsblock.Update
rsblock.Close
dbblock.Close
Set rsblock = Nothing
Set dbblock = Nothing
Dim G_dbf_path As String
G_dwg_path = thisdrawing.Path & "\" & thisdrawing.Name
G_dbf_path = Left(G_dwg_path, (Len(G_dwg_path) - 4)) & "-PID.mdb"
'Verbinding maken met database
Set dbInfo = opendatabase(G_dbf_path)
Set rsInfo = dbInfo.OpenRecordset("Attributes", dbOpenTable)
Set rsData = dbInfo.OpenRecordset("Add_info", dbOpenTable)
Set rsPED = dbInfo.OpenRecordset("PED_info", dbOpenTable)
Set rsLink = dbInfo.OpenRecordset("Link_info", dbOpenTable)
Set rsCdesc = dbInfo.OpenRecordset("Client_desc_info", dbOpenTable)
''For Each elem In ThisDrawing.ModelSpace
With Object
If ((.HasAttributes) And (Left(elem.Name, 3) = "G_B") Or (Left(elem.Name, 3) = "G_E") Or (Left(elem.Name, 3) = "G_I")) Then
'Gea_ordernummer = thisdrawing.GetVariable("PROJECTNAME")
Call GEA_code_start.G_update_db(Object, Gea_ordernummer)
'MsgBox "Instructie" & thisdrawing.GetVariable("CMDNAMES")
Else
End If
End With
rsData.Close
rsPED.Close
rsLink.Close
rsCdesc.Close
rsInfo.Close
dbInfo.Close
Set rsData = Nothing
Set rsPED = Nothing
Set rsLink = Nothing
Set rsCdesc = Nothing
Set rsInfo = Nothing
Set dbInfo = Nothing
End If
End If
thisdrawing.EndUndoMark
Exit Sub
Err_objera:
If Err.Number = 3024 Then Exit Sub Else Resume Next
End Sub
Public Sub G_frmt_chk()
Dim l As Integer
G_name_chk = False
G_dwg_path = thisdrawing.Path & "\" & thisdrawing.Name
G_dwg_name = UCase(thisdrawing.Name)
l = Len(G_dwg_name)
G_dwg_name = Left(G_dwg_name, l - 4)
G_name_chk = (Left(G_dwg_name, 1) Like "~")
writelock = thisdrawing.GetVariable("WRITESTAT")
If writelock = 0 Then
G_name_chk = False
End If
End Sub
但我们希望使我们的符号（具有属性的块）动态（可视性状态）。当我们添加动态块时，插入时间太长！动态块中的每个元素都是“添加的对象”，因此每个元素都必须通过上面的VBA。当动态块的可视性状态改变时。它还通过VBA运行。这会让您等待大约15到45秒。
现在有人知道如何更快地做到这一点吗？也许我可以过滤动态块和其他元素，这样只有属性才能通过？还有其他想法吗？
非常感谢您的提示！ 您可以通过重新排列来减少数据库打开开销，这样dbblock和rsblock就可以在需要之前（并且只有在需要时）创建：
...
如果（G\u name\u add=“AcadBlockReference”），则
如果（（Left（Object.Name，3）=“G\u B”）或（Left（Object.Name，3）=“G\u E”）或_
（左（Object.Name，3）=“G_I”）或（左（Object.Name，3）=“G_A”））然后
Set dbblock=opendatabase（G\u tmp\u db）
设置rsblock=dbblock。OpenRecordset（“块”，dbOpenTable）
rsblock。添加新的
rsblock（“ObjectID”）=对象。ObjectID
rsblock（“句柄”）=对象。手柄
rsblock。使现代化
rsblock。关
数据库块。关
设置rsblock=Nothing
设置dbblock=Nothing
...
希望这有帮助，
休·亚达斯蒙
Cadro私人有限公司
www.hatchkit。通用域名格式。澳大利亚
很抱歉反应太晚。。。
谢谢你的回复。我还没有测试它，但它看起来更符合逻辑。
页:
[1]