这里有一个片段可以做到这一点。您可能需要根据自己的喜好进行调整
- Option Explicit
- Public Tatts As Variant
- Public ssnew_usr As Object
- Const DATABASE_DIR = "q:\std\drafting_db"
- Dim db As DAO.Database
-
- Sub ge_user_time()
- Dim login As String
- Dim dwg_nm As String
- Dim SysVarName As String
- Dim MyDate
- Dim mod_date As Variant
- Dim time_tmp_cnt As Variant
- Dim time_cnt As Variant
- Dim MyTime
- Dim objSelSet As AcadSelectionSet
- Dim objSelCol As AcadSelectionSets
- Set objSelCol = ThisDrawing.SelectionSets
- For Each objSelSet In objSelCol
- If objSelSet.Name = "user1_cnt" Then
- objSelSet.Delete
- Exit For
- End If
- Next
- SysVarName = "LOGINNAME"
- login = ThisDrawing.GetVariable(SysVarName)
- MyTime = Time
- MyDate = Date
- mod_date = MyDate & " " & MyTime
- SysVarName = "USERS5"
- time_tmp_cnt = ThisDrawing.GetVariable(SysVarName)
- Dim EntGrp(0) As Integer
- Dim EntPrp(0) As Variant
- Dim BlkObj As Object
- Dim Pt1(0) As Double
- Dim Pt2(0) As Double
- Set ssnew_usr = ThisDrawing.SelectionSets.Add("user1_cnt")
- EntGrp(0) = 2
- EntPrp(0) = "drafting_db_block"
- ssnew_usr.Select acSelectionSetAll, Pt1, Pt2, EntGrp, EntPrp
- If ssnew_usr.Count >= 1 Then
- Call cadreq_str
- Tatts = ssnew_usr.Item(0).GetAttributes
- dwg_nm = (LTrim(Tatts(3).TextString))
- Set db = DAO.OpenDatabase(DATABASE_DIR & "drafting_db_oldver.mdb", False, False)
- Dim rs As DAO.Recordset
- Set rs = db.OpenRecordset( _
- "SELECT * FROM USER_INFO WHERE CaddReq = '" _
- & cad_req & "' AND DrawingName = '" & dwg_nm & "' AND UserID = '" & login & "'")
- If (rs.RecordCount > 0) Then
- time_tmp_cnt = rs.Fields("Time") + time_tmp_cnt
- rs.Edit
- rs.Fields("Mod_Date") = MyDate
- rs.Fields("Mod_Time") = MyTime
- rs.Fields("Time") = time_tmp_cnt
- On Error Resume Next
- rs.Update
- Else
- rs.AddNew
- rs.Fields("UserID") = login
- rs.Fields("CaddReq") = cad_req
- rs.Fields("DrawingName") = dwg_nm
- rs.Fields("Time") = time_tmp_cnt
- On Error Resume Next
- rs.Fields("Mod_Date") = MyDate
- rs.Fields("Mod_Time") = MyTime
- rs.Update
- End If
- rs.Close
- Set rs = Nothing
- db.Close
- Set db = Nothing
- End If
- End Sub
您可能需要检查这些才能使其工作:
快乐编码。 |