问题描述：写了个类模块OceDoor，图中选择一个矩形多段线后，发现修改多段线坐标后没有反应......
1）以下是 ThisDrawing 里面的代码：
==========================================================================================
Public Sub BBB_GoTestHere() 这个是运行的主过程
Dim SeleObjts As AcadSelectionSet
Dim Objt As Object
Dim Door As New OceDoor
Call CreateSelectionSet(SeleObjts, "Doors"): SeleObjts.SelectOnScreen
For Each Objt In SeleObjts
If TypeOf Objt Is AcadLWPolyline Then Set Door.OutLine = Objt
Next Objt
Set SeleObjts = Nothing
Let Door.Width = 5000 这设置宽度，原来宽度是 1200，运行后矩形没变大
End Sub
==========================================================================================
Sub CreateSelectionSet(SeleObjts As AcadSelectionSet, Name As String)
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item(Name)) Then
Set SeleObjts = ThisDrawing.SelectionSets.Item(Name)
SeleObjts.Delete
End If
Set SeleObjts = ThisDrawing.SelectionSets.Add(Name)
End Sub
==========================================================================================
2）以下是 OceDoor 里面的代码：
Dim Rect As AcadLWPolyline
Dim b0 As Double: Dim Xc As Double
==========================================================================================
Public Property Set OutLine(ByVal NewValue As AcadLWPolyline)
Set Rect = NewValue: Call DataUpdate
End Property
==========================================================================================
Public Property Get OutLine() As AcadLWPolyline
Set OutLine = Rect
End Property
==========================================================================================
Private Sub DataUpdate() 数据更新
b0 = Abs(Rect.Coordinate(1)(0) - Rect.Coordinate(3)(0))
h0 = Abs(Rect.Coordinate(1)(1) - Rect.Coordinate(3)(1))
Xc = 0.5 * (Rect.Coordinate(1)(0) + Rect.Coordinate(3)(0))
Yc = 0.5 * (Rect.Coordinate(1)(1) + Rect.Coordinate(3)(1))
Rect.Update
End Sub
==========================================================================================
Public Property Get Width() As Double 宽度属性取值
Width = b0
End Property
==========================================================================================
Public Property Let Width(ByVal NewValue As Double) 宽度属性赋值
Dim Xmax As Double: Xmax = Xc + 0.5 * NewValue
Dim Xmin As Double: Xmin = Xc - 0.5 * NewValue
Rect.Coordinate(0)(0) = Xmin： Rect.Coordinate(2)(0) = Xmax
Rect.Coordinate(1)(0) = Xmax： Rect.Coordinate(3)(0) = Xmin
Call DataUpdate
End Property
简化下代码，这样也无法修改坐标：
Option Explicit
Public Sub BBB_GoTestHere()
Dim SeleObjts As AcadSelectionSet
Dim Objt As Object
Dim Rect As AcadPolyline
Call CreateSelectionSet(SeleObjts, "Polys")
SeleObjts.SelectOnScreen
For Each Objt In SeleObjts
If TypeOf Objt Is AcadPolyline Then Set Rect = Objt
Next Objt
Set SeleObjts = Nothing
Rect.Coordinates(0) = 5000 '就是这里，根本改不了坐标
End Sub
Sub CreateSelectionSet(SeleObjts As AcadSelectionSet, Name As String)
On Error Resume Next
If Not IsNull(ThisDrawing.SelectionSets.Item(Name)) Then
Set SeleObjts = ThisDrawing.SelectionSets.Item(Name)
SeleObjts.Delete
End If
Set SeleObjts = ThisDrawing.SelectionSets.Add(Name)
End Sub
置顶卡
