[编程交流] 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