Поворот объекта "по линейке"

[_MBK_]

Довольно часто бывает нужно повернуть объект (например криво остканированый битмап) не на определенный угол, а, чтобы определенные линии на нем стали строго горизонтальными или вертикальными. Стандартным инструментом это несколько неудобно: надо выставлять центр поворота, направляющие, да и то "на глаз" не сразу попадешь.
А в фотошопе для этого есть чудесный инструмент - линейка. Рисуешь линеечку поверх линии, которую выровнять надо а затем поворачиваешь изображение по ней - секундное дело.
Нет ли в кореле подобного скрипта? Пишется в общем-то элементарно, зато пользы сколько. Неужели никто не реализовал до сих пор?

 

[lev]

Ответ: Поворот объекта "по линейке"

А зачем именно скрипт? Имхо устарели они. Но раз так хочется:

'2 click rotate.csc
withobject "coreldraw.automation.9"
dim x(2)
dim y(2)
.SetReferencePoint 9
for i=1 to 2
.GetUserClick nX&,nY&
x(i)=nx
y(i)=ny
next i
dx=x(2)-x(1)
dy=y(2)-y(1)
if dx <>0 then
angle=ANGLECONVERT(2,5,atan(dy/dx))
.RotateObject -angle, -1, 0,0
end if
.setreferencepoint 3
end withobject

Поправить под нужную версию. Где-то и макрос валялся.

Неужели никто не реализовал до сих пор?

Судя по дате файла последнюю правку вносил в 2008.

 

[_MBK_]

Ответ: Поворот объекта "по линейке"

Спасибо, уже сам написал. ;-)

 

[Lena_sun]

Ответ: Поворот объекта "по линейке"

Довольно часто бывает нужно повернуть объект (например криво остканированый битмап)

Для не ровно отсканированных изображений также в Corel PHOTO-PAINT поворот по сетке: Меню Adjust->Straighten Image...

 

[_MBK_]

Ответ: Поворот объекта "по линейке"

Вот мой вариант. Рисуется отрезок, выделяется вместе с объектом, который повернуть надо и запускается скрипт. Вертикальные отрезки выравнивает к вертикали а горизонтальные - к горизонтали, как в фотошопе:

Sub Rotate()

ActiveDocument.BeginCommandGroup "Auto rotate"

Dim Sel As ShapeRange, S As Shape, St() As New ShapeRange, Tmp As New ShapeRange
Dim I As Integer, Changed As Boolean, U As Integer, Finded As Boolean

    
    
    If Documents.Count = 0 Then Exit Sub
    ActiveDocument.ReferencePoint = cdrCenter
    Set Sel = ActiveSelectionRange
    If Sel.Count < 2 Then Exit Sub
    
    Line = 0
    
    For I = 1 To Sel.Count
       If Sel(I).Type = cdrCurveShape Then
         If Sel(I).Curve.Nodes.Count = 2 Then Line = I
       End If
    Next I
    
    If Line = 0 Then Exit Sub
    
    If Sel(Line).RightX = Sel(Line).LeftX Then Exit Sub
    If Sel(Line).BottomY = Sel(Line).TopY Then Exit Sub
    
    X1 = Sel(Line).Curve.Nodes(1).PositionX
    X2 = Sel(Line).Curve.Nodes(2).PositionX
    Y1 = Sel(Line).Curve.Nodes(1).PositionY
    Y2 = Sel(Line).Curve.Nodes(2).PositionY
    
    If Abs(Y1 - Y2) > Abs(X1 - X2) Then
     
     If Y2 > Y1 Then
      A = X1
      X1 = X2
      X2 = A
      A = Y1
      Y1 = Y2
      Y2 = A
     End If
     alpha = -Atn((X1 - X2) / (Y2 - Y1)) / 3.14 * 180
     
     
    
    Else
    
    
    If X1 > X2 Then
      A = X1
      X1 = X2
      X2 = A
      A = Y1
      Y1 = Y2
      Y2 = A
    End If
    alpha = Atn((Y1 - Y2) / (X2 - X1)) / 3.14 * 180
    
    End If
    
    
    
    
    
    For I = 1 To Sel.Count
      Sel(I).Rotate (alpha)
    Next I
    

ActiveDocument.EndCommandGroup
End Sub

Проверял под X3-X5