Проблема с переносом системы координат

У меня возникли проблемы с переносом системы координат.
Запускаю процедуру черчу деталь переношу UCS при этом значок переносится на нужное место.
Запускаю процедуру повторно, деталь начинает прорисовываться не с той точки где находится значок UCS, а с той же точки откуда начинала чертиться первая деталь.
Вот код процедуры VBA помогите пожалуйста разобраться что здесь не так.
Private Sub cmdDrawDucts_Click()
Dim ucsObj1 As AcadUCS
Dim origin(0 To 2) As Double
Dim xAxisPoint(0 To 2) As Double
Dim yAxisPoint(0 To 2) As Double
origin(0) = 2: origin(1) = 2: origin(2) = 0
xAxisPoint(0) = 3: xAxisPoint(1) = 2: xAxisPoint(2) = 0
yAxisPoint(0) = 2: yAxisPoint(1) = 3: yAxisPoint(2) = 0
Set ucsObj1 = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPoint, yAxisPoint, "UCS0")
ThisDrawing.ActiveUCS = ucsObj
Dim plineObj As AcadPolyline 'Объявляем переменную полилиния
Dim dWidth As Double 'Объявляем переменную "Ширина"
Dim dHeight As Double 'Объявляем переменную "Высота"
Dim points(0 To 11) As Double 'Объявляем переменную "точки" с 1-й по 4-ю координат полилинии
dWidth = CDbl(txtWidth.Text) 'Присваиваем переменной число из техтового бокса Ширина
dHeight = CDbl(txtHeight.Text) 'Присваиваем переменной число из техтового бокса Высота
' Определяем четыре двухмерные точки полилинии и рисуем п образный прямоугольник
points(0) = 0: points(1) = 0: points(2) = 0 'Определяем первую левую нижнюю точку
'по координатам X,Y,Z
points(3) = 0: points(4) = dHeight: points(5) = 0 'Определяем вторую левую верхнюю точку
'по координатам X,Y,Z
points(6) = dWidth: points(7) = dHeight: points( = 0 'Определяем третью правую верхнюю точку
'по координатам X,Y,Z
points(9) = dWidth: points(10) = 0: points(11) = 0 'Определяем четвёртую правую нижнюю точку
'по координатам X,Y,Z
' Создаём п образный контур полилинии в пространстве модели
Set plineObj = ThisDrawing.ModelSpace.AddPolyline(points)
' Присваиваем своиству полилинии "closed" статус "True"-истиный
' и тем самым замыкаем прямоугольник
plineObj.Closed = True
ThisDrawing.Regen (True)
Dim dLenght As Double 'Объявляем переменную "Длинна"
dLenght = CDbl(txtLenght.Text) 'Присваиваем переменной число из текстового бокса Длина
plineObj.Thickness = 0 'Придаём полилинии толщину по оси Z на величину из текстового бокса Длина
ZoomAll
'Переносим систему координат
Dim ucsObj As AcadUCS
Dim origin(0 To 2) As Double
Dim xAxisPoint(0 To 2) As Double
Dim yAxisPoint(0 To 2) As Double
origin(0) = points(0): origin(1) = points(1): origin(2) = dLenght
yAxisPoint(0) = points(3): yAxisPoint(1) = points(4): yAxisPoint(2) = dLenght
xAxisPoint(0) = points(9): xAxisPoint(1) = points(11): xAxisPoint(2) = dLenght
Set ucsObj = ThisDrawing.UserCoordinateSystems.Add(origin, xAxisPoint, yAxisPoint, "UCS1")
ThisDrawing.ActiveUCS = ucsObj
ThisDrawing.Regen True
End Sub