VBA 双击修改
Private Sub AcadDocument_BeginDoubleClick(ByVal PickPoint As Variant) '双击文字修改 On Error Resume Next Dim T As AcadText Dim Temp As String Dim T1 As Integer Dim T2 As Integer Dim T3 As Integer Dim L As Integer 'If PickfirstSelectionSet.Count <> 1 Then Exit Sub Dim SSetObj As AcadSelectionSet If PickfirstSelectionSet.Item(0).ObjectName = "AcDbText" Then If Err.Number = -2145320949 Then If Err.Number > 0 Then Err.Clear Set SSetObj = CreateSelectionSet("XXX") SSetObj.SelectAtPoint PickPoint '设置个选择之后,双击就不会在执行DDedit了 'ThisDrawing.SetVariable "USERS2", "%%130%%131%%132" Set T = SSetObj.Item(0) Temp = T.TextString Temp = Replace(Temp, "\U+0082", "%%130") Temp = Replace(Temp, "\U+0083", "%%131") Temp = Replace(Temp, "\U+0084", "%%132") T.TextString = Temp T1 = InStr(Temp, "%%130") T2 = InStr(Temp, "%%131") T3 = InStr(Temp, "%%132") L = Len(Temp) If T1 + T2 + T3 > 0 And L < 40 Then Set SSetObj = CreateSelectionSet("XXX") SSetObj.SelectAtPoint PickPoint '设置个选择之后,双击就不会在执行DDedit了 ThisDrawing.SetVariable "USERS2", "%%130%%131%%132" Exit Sub Else Dim P As String P = PickPoint(0) & " " & PickPoint(1) & " " & PickPoint(2) Dim P1 As String P1 = PickPoint(0) + 1 & " " & PickPoint(1) + 1 & " " & PickPoint(2) ThisDrawing.SendCommand ("ddedit w " & P & " " & P1 & " ") Exit Sub End If End If Set T = PickfirstSelectionSet.Item(0) Temp = T.TextString Temp = Replace(Temp, "\U+0082", "%%130") Temp = Replace(Temp, "\U+0083", "%%131") Temp = Replace(Temp, "\U+0084", "%%132") T.TextString = Temp T1 = InStr(Temp, "%%130") T2 = InStr(Temp, "%%131") T3 = InStr(Temp, "%%132") L = Len(Temp) If T1 + T2 + T3 > 0 And L < 40 Then Set SSetObj = CreateSelectionSet("XXX") SSetObj.SelectAtPoint PickPoint '设置个选择之后,双击就不会在执行DDedit了 ThisDrawing.SetVariable "USERS2", "%%130%%131%%132" End If End If If Err.Number > 0 Then Err.Clear Exit Sub E: MsgBox Err.Number Err.Clear End Sub '创建选择集******************************************************创建选择集********************************************************** ' Public Function CreateSelectionSet(Optional ssName As String = "ss") As AcadSelectionSet '返回一个空白选择集
Dim ss As AcadSelectionSet
On Error Resume Next Set ss = ThisDrawing.SelectionSets(ssName) If Err Then Set ss = ThisDrawing.SelectionSets.Add(ssName) ss.Clear Set CreateSelectionSet = ss End Function '*********************************************************************************************************************************** |