[CDR 2023] [VBA] Как скопировать второй узел управления градиента?

[ydobemos]

Привет.

Я пытаюсь создать макрос, который создает «расширенный» градиент для объекта. Таким образом, прямоугольник с этим градиентом может быть помещен в объекты с разными пропорциями и выглядеть одинаково. Слева то, что мы можем сейчас получить, а справа то, что нам нужно:

Код выглядит следующим образом:

Sub ReplaceGradient()
    Dim S As Shape
    Dim T As Shape
    
    Dim EE As String
    Dim SplitEE() As String
    Dim E2X As Double
    Dim E2Y As Double
    
    Set S = ActiveShape
    
    ActiveDocument.Unit = cdrMillimeter
    
    Set T = ActiveLayer.CreateRectangle(S.LeftX - 100, S.TopY + 100, S.RightX + 100, S.BottomY - 100)
    T.Fill.CopyAssign S.Fill
    
    With S.Fill.Fountain
        T.Fill.Fountain.startX = .startX
        T.Fill.Fountain.startY = .startY
        T.Fill.Fountain.EndX = .EndX
        T.Fill.Fountain.EndY = .EndY
        
        T.Fill.Fountain.Skew = .Skew
        
        T.Fill.Fountain.CenterOffsetX = .CenterOffsetX
        T.Fill.Fountain.CenterOffsetY = .CenterOffsetY
        
        T.Fill.Fountain.End2X = .End2X
        T.Fill.Fountain.End2Y = .End2Y
    End With
    
    T.OrderBackOf S
End Sub

Казалось бы, End2X и End2Y — то, что нам нужно. Но запуск кода выдает сообщение об ошибке. Есть идеи?

 

[_MBK_]

Не совсем понимаю зачем второе присвоение, разве CopyAssign не делает то же самое?
А почему нельзя просто продублировать объект сверху и обрезать через Intersect, например?

 

[ydobemos]

Я предполагал, что иллюстрация объяснит это. Градиент смещается. Но мне нужно, чтобы он ТОЧНО дублировал и продолжил то, как он выглядит на базовом объекте. Вы можете попробовать это на чем-то с повернутым градиентом, и все должно стать яснее.

CopyAssign делает то, что можете видеть на левом изображении — сдвиг градиента.

 

[_MBK_]

Я предполагал, что иллюстрация объяснит это. Градиент смещается. Но мне нужно, чтобы он ТОЧНО дублировал и продолжил то, как он выглядит на базовом объекте. Вы можете попробовать это на чем-то с повернутым градиентом, и все должно стать яснее.

CopyAssign делает то, что можете видеть на левом изображении — сдвиг градиента.

Вы не повторите сложный градиент, чтобы он идеально вписывался в исходный, во всяком случае это почти нетривиально. Поэтому, настоятельно советую подумать про обрезку дублированного объекта.

 

[eugeny]

Проще сделать маску состоящую из нужного по размерам прямоугольника и прямоугольника больше исходного объекта (combine двух прямоугольников).
потом сдублировать фон (если оригинал будет еще нужен).
применить trim.
удалить маску.

или, как сказали через Intersect

 

[ydobemos]

Вы не повторите сложный градиент, чтобы он идеально вписывался в исходный, во всяком случае это почти нетривиально. Поэтому, настоятельно советую подумать про обрезку дублированного объекта.

Ну в том то и дело, что это не сложно. Я переделал пример, чтобы вы могли проверить это. Запустите его, и вы увидите, что большой прямоугольник почти правильный. Если щелкнете по нему инструментом градиента и перетащите круглый узел в то же место, что и на первом градиенте, второй градиент будет точной копией.

Sub ReplaceGradient()
    Dim S As Shape
    Dim T As Shape
    
    Dim EE As String
    Dim SplitEE() As String
    Dim E2X As Double
    Dim E2Y As Double
    
    ActiveDocument.Unit = cdrMillimeter
    
    Set S = ActiveLayer.CreateRectangle2(50, 100, 100, 200)
    S.Fill.ApplyFountainFill CreateRGBColor(255, 128, 0), CreateRGBColor(0, 192, 255), , 30
    S.Fill.Fountain.Colors.Add CreateRGBColor(255, 192, 0), 33
    
    Dim F As FountainFill
    Set F = S.Fill.Fountain
    
    ActiveLayer.CreateEllipse2 F.StartX, F.StartY, 5
    ActiveLayer.CreateEllipse2 F.EndX, F.EndY, 5
    'Should be different?
    ActiveLayer.CreateEllipse2 F.End2X, F.End2Y, 5
    
    Set T = ActiveLayer.CreateRectangle(S.LeftX - 100, S.TopY + 100, S.RightX + 100, S.BottomY - 100)
    T.Fill.CopyAssign S.Fill
    T.OrderBackOf S

    T.Fill.Fountain.StartX = S.Fill.Fountain.StartX
    T.Fill.Fountain.StartY = S.Fill.Fountain.StartY
    T.Fill.Fountain.EndX = S.Fill.Fountain.EndX
    T.Fill.Fountain.EndY = S.Fill.Fountain.EndY
End Sub

Я не знаю, являются ли End2X и End2Y координатами этого круглого узла, но кажется, что они должны быть. Но с VBA он имеет те же координаты, что и EndX и EndY. Так что в основном мне просто нужно получить координаты круглого узла, и это будет точная копия. Это работает, когда делается вручную.

 

[ydobemos]

Почему в этом месте есть таймер редактирования...

Во всяком случае, я сделал анимированный gif, который показывает эту проблему. Нижний прямоугольник — копия из макроса. Узлы градиента размещаются так же, как и на базовой фигуре. Когда мы перемещаем этот круглый узел вручную, результатом является точное наложение.

потом сдублировать фон

Если я не делаю что-то не так, клонированный фон по-прежнему имеет неправильный угол и размер.

 

[_MBK_]

Ну в том то и дело, что это не сложно. Я переделал пример, чтобы вы могли проверить это. Запустите его, и вы увидите, что большой прямоугольник почти правильный. Если щелкнете по нему инструментом градиента и перетащите круглый узел в то же место, что и на первом градиенте, второй градиент будет точной копией.

Sub ReplaceGradient()
    Dim S As Shape
    Dim T As Shape
  
    Dim EE As String
    Dim SplitEE() As String
    Dim E2X As Double
    Dim E2Y As Double
  
    ActiveDocument.Unit = cdrMillimeter
  
    Set S = ActiveLayer.CreateRectangle2(50, 100, 100, 200)
    S.Fill.ApplyFountainFill CreateRGBColor(255, 128, 0), CreateRGBColor(0, 192, 255), , 30
    S.Fill.Fountain.Colors.Add CreateRGBColor(255, 192, 0), 33
  
    Dim F As FountainFill
    Set F = S.Fill.Fountain
  
    ActiveLayer.CreateEllipse2 F.StartX, F.StartY, 5
    ActiveLayer.CreateEllipse2 F.EndX, F.EndY, 5
    'Should be different?
    ActiveLayer.CreateEllipse2 F.End2X, F.End2Y, 5
  
    Set T = ActiveLayer.CreateRectangle(S.LeftX - 100, S.TopY + 100, S.RightX + 100, S.BottomY - 100)
    T.Fill.CopyAssign S.Fill
    T.OrderBackOf S

    T.Fill.Fountain.StartX = S.Fill.Fountain.StartX
    T.Fill.Fountain.StartY = S.Fill.Fountain.StartY
    T.Fill.Fountain.EndX = S.Fill.Fountain.EndX
    T.Fill.Fountain.EndY = S.Fill.Fountain.EndY
End Sub

Я не знаю, являются ли End2X и End2Y координатами этого круглого узла, но кажется, что они должны быть. Но с VBA он имеет те же координаты, что и EndX и EndY. Так что в основном мне просто нужно получить координаты круглого узла, и это будет точная копия. Это работает, когда делается вручную.

Это иллюзия. На самом деле, для произвольных сложных объектов и градиентов пересчет координат этих ползунков весьма серьезным матаном может оказаться.

Если я не делаю что-то не так, клонированный фон по-прежнему имеет неправильный угол и размер.

Не понял - вы программно обьект дублируете, при этом градиент слетает??? Это явный баг, такого не должно быть

 

[ydobemos]

Это иллюзия. На самом деле, для произвольных сложных объектов и градиентов пересчет координат этих ползунков весьма серьезным матаном может оказаться.

Не могу сказать, что я согласен - градиент есть градиент, у него есть начальная точка, конечная точка и преобразования, такие как масштаб, вращение и т. д. Если "Free scale and scew" активен, мы можем скопировать их и результат будет тот же.

Что ж, это потенциально главный вопрос здесь — можем ли мы просто переместить этот конечный узел из пользовательского интерфейса с помощью кода или это просто визуальное представление для пользователя, и к нему нельзя получить доступ через VBA.

И тогда да, нам нужно будет пересчитать угол, наклон, масштаб и все это на основе различий в размерах фигур. В таком случае непонятно, для чего в коде используются PosX2 и PosY2.

Не понял - вы программно обьект дублируете, при этом грвдиент слетает??? Это явный баг, такого не должно быть

Если я меняю размер чего-либо, градиент также меняется. Неважно, будет ли это группа или потом спаянная воедино или что-то в этом роде.

 

[Акулыч]

как вариант, можно вообще в поверклип закинуть и не париться. Все градиенты будут корректными

 

[ydobemos]

как вариант, можно вообще в поверклип закинуть и не париться. Все градиенты будут корректными

На самом деле я делаю это для добавления градиента в PowerClip... То есть мы берем любой градиент, который пользователь применил к этому объекту PowerClip, а затем применяем его к этому увеличенному прямоугольнику, чтобы мы могли надежно перенести его на другие объекты. Это основная цель этого макроса.

А пока придумал, как сделать, если наша большая фигура имеет точно такие же пропорции. Это не идеально, но может сработать.

Sub TryTransformation()
    Dim S As Shape
    Dim T As Shape
    Set S = ActiveSelectionRange.shapes.First
    Set T = ActiveSelectionRange.shapes.Last
   
    Dim d11 As Double
    Dim d12 As Double
    Dim d21 As Double
    Dim d22 As Double
   
    Dim HRatio As Double
    Dim VRatio As Double
   
    HRatio = S.SizeWidth / T.SizeWidth
    VRatio = S.SizeHeight / T.SizeHeight
   
    S.Fill.Fountain.GetTransformations d11, d12, d21, d22
    T.Fill.Fountain.SetTransformations d11 * HRatio, d12 * HRatio, d21 * HRatio, d22 * HRatio
End Sub

Теперь попробуем добавить математику для работы с другими пропорциями объекта...

 

[_MBK_]

Что ж, это потенциально главный вопрос здесь — можем ли мы просто переместить этот конечный узел из пользовательского интерфейса с помощью кода или это просто визуальное представление для пользователя, и к нему нельзя получить доступ через VBA

Конечно можем, но в данном случае вы просто тратите время на поиск одного из мелких багов на тернистом пути в тупик.

Если я меняю размер чего-либо, градиент также меняется. Неважно, будет ли это группа или потом спаянная воедино или что-то в этом роде.

Да не надо вам размеры менять и вообще любой трансформацией обьекта заниматься, ибо это погубит градиент. Просто обрежьте и не трогайте - это будет самым простым и правильным решением в данном случае.
Не надо строить синрофазатрон для того, чтобы зарядить мобильный телефон.

 

[ydobemos]

Конечно можем

Если вы знаете, как переместить этот круглый узел через VBA, поделитесь, пожалуйста.

Да не надо вам размеры менять и вообще любой трансформацией обьекта заниматься

Я не объясняю точный сценарий использования, потому что здесь это не обязательно важно. Но в целом представьте, что нам нужно получить точный размер, угол и т. д. градиента, созданного нашим пользователем, и применить его к большому количеству форм и размеров. Вот почему мы хотим просто позволить им создать «точную» копию, которая намного больше во всех направлениях. Затем они могут поместить ето во что угодно с помощью PowerClip.

 

[_MBK_]

Видимо, я с годами теряю дар объяснения, или вы в упор не хотите понять, что я до вас хочу донести.
У вас на всех скринах и видео частный случай простого линейного градиента, у которого средние стопы каким то волшебным образом совпадают, что при масштабировании и перемещении совпадают и цвета в крайних точках. Попробуйте градиент посложнее или, наоборот по проще и вы увидите, что при изменении размера вам придется и стопы двигать и даже перекрашивать их.
Или это я чего то не догоняю в вашей специфической задаче???

 

[_MBK_]

Если вы знаете, как переместить этот круглый узел через VBA, поделитесь, пожалуйста.

Ну если уж вам так хочется поправить узел, то изменение уже назначенного объекту FountainFill представляется мне сомнительной идеей. По хорошему надо заново назначать объекту градиент через Fill.ApplyFountainFill с нужными параметрами

 

[Акулыч]

на мой взгляд, простая обрезка (Intersect) дает те же самые результаты. Поэкспериментировал - всё корректно обрезается, градиент остается на месте, никуда не смещается.

 

[ydobemos]

Так или иначе, это побудило меня отказаться от попыток получить координаты X2 и Y2 и найти что-то другое. В этом случае GetTransformations и SetTransformations. Работают на 99% отлично:

Sub TryTransformation()
    ActiveDocument.Unit = cdrMillimeter

    Dim S As Shape
    Dim T As Shape
    Set S = ActiveSelectionRange.shapes.First
    
    Set T = ActiveLayer.CreateRectangle(S.LeftX - 50, S.TopY + 100, S.RightX + 50, S.BottomY - 100)
    T.Fill.CopyAssign S.Fill
    T.OrderBackOf S
    
    Dim d11 As Double
    Dim d12 As Double
    Dim d21 As Double
    Dim d22 As Double
    
    Dim HRatio As Double
    Dim VRatio As Double
    
    HRatio = S.SizeWidth / T.SizeWidth
    VRatio = S.SizeHeight / T.SizeHeight
    
    S.Fill.Fountain.GetTransformations d11, d12, d21, d22
    T.Fill.Fountain.SetTransformations d11 * HRatio, d12 * HRatio, d21 * VRatio, d22 * VRatio
End Sub

Спасибо всем за вдохновение.