无法修改多段线的坐标？？？
问题描述：写了个类模块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 本帖最后由 woaishuijia 于 2019-2-21 14:14 编辑
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
Dim V(7) As Double
V(0) = Xmin
V(1) = Rect.Coordinates(1)
V(2) = Xmax
V(3) = Rect.Coordinates(3)
V(4) = Xmax
V(5) = Rect.Coordinates(5)
V(6) = Xmin
V(7) = Rect.Coordinates(7)
Rect.Coordinates = V
Call DataUpdate
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
Dim V(1) As Double
V(0) = Xmin
V(1) = Rect.Coordinates(1)
Rect.Coordinate(0) = V
V(1) = Rect.Coordinates(7)
Rect.Coordinate(3) = V
V(0) = Xmax
V(1) = Rect.Coordinates(3)
Rect.Coordinate(1) = V
V(1) = Rect.Coordinates(5)
Rect.Coordinate(2) = V
Call DataUpdate
End Property
就是不能单个坐标这样修改，，，
谢谢！！！
页:
[1]