[CDR 2025] Ищу макрос покраски абриса в цвет заливки

I

iKoolk

Участник
Топикстартер
Сообщения
237
Реакции
11
Бодрый день, коллеги!
Собственно, ищу макрос покраски абриса в цвет заливки. Знаю точно такой есть. Писать сейчас некогда.

Поделитесь, пожалуйста
 
Код: 
Sub OutlineToFillColor()
    Dim s As Shape
    Dim fillColor As Color
    Dim outlineColor As Color
    
    ' Ïðîâåðÿåì, åñòü ëè âûäåëåííûå îáúåêòû
    If ActiveSelection.Shapes.Count = 0 Then
        MsgBox "Ïîæàëóéñòà, âûäåëèòå îáúåêòû ñíà÷àëà.", vbExclamation, "Íåò âûäåëåíèÿ"
        Exit Sub
    End If
    
    ' Íà÷èíàåì îïåðàöèþ, êîòîðóþ ìîæíî îòìåíèòü
    ActiveDocument.BeginCommandGroup "Outline to Fill Color"
    
    ' Ïåðåáèðàåì âñå âûäåëåííûå îáúåêòû
    For Each s In ActiveSelection.Shapes
        ' Ïðîâåðÿåì, åñòü ëè ó îáúåêòà çàëèâêà
        If s.Fill.Type <> cdrNoFill Then
            ' Ïîëó÷àåì öâåò çàëèâêè
            Set fillColor = s.Fill.UniformColor
            
            ' Óñòàíàâëèâàåì ýòîò æå öâåò äëÿ àáðèñà
          
            Set outlineColor = fillColor
            s.Outline.SetProperties Color:=outlineColor
          
        End If
    Next s
    
    ' Çàâåðøàåì îïåðàöèþ
    ActiveDocument.EndCommandGroup
End Sub
 
  • Спасибо
Реакции: dastin, mnemonix и iKoolk
спасибо
zollinger сказал(а):
Код: 
Sub OutlineToFillColor()
    Dim s As Shape
    Dim fillColor As Color
    Dim outlineColor As Color
   
    ' Ïðîâåðÿåì, åñòü ëè âûäåëåííûå îáúåêòû
    If ActiveSelection.Shapes.Count = 0 Then
        MsgBox "Ïîæàëóéñòà, âûäåëèòå îáúåêòû ñíà÷àëà.", vbExclamation, "Íåò âûäåëåíèÿ"
        Exit Sub
    End If
   
    ' Íà÷èíàåì îïåðàöèþ, êîòîðóþ ìîæíî îòìåíèòü
    ActiveDocument.BeginCommandGroup "Outline to Fill Color"
   
    ' Ïåðåáèðàåì âñå âûäåëåííûå îáúåêòû
    For Each s In ActiveSelection.Shapes
        ' Ïðîâåðÿåì, åñòü ëè ó îáúåêòà çàëèâêà
        If s.Fill.Type <> cdrNoFill Then
            ' Ïîëó÷àåì öâåò çàëèâêè
            Set fillColor = s.Fill.UniformColor
           
            ' Óñòàíàâëèâàåì ýòîò æå öâåò äëÿ àáðèñà
         
            Set outlineColor = fillColor
            s.Outline.SetProperties Color:=outlineColor
         
        End If
    Next s
   
    ' Çàâåðøàåì îïåðàöèþ
    ActiveDocument.EndCommandGroup
End Sub
Нажмите, чтобы раскрыть...
спасибо
 
просто тарабарщина какая-то ...
лучше так
Код: 
Sub OutlineToFillColor()
    Dim s As Shape
    Dim fillColor As Color
    Dim outlineColor As Color
    
    ' Проверяем, есть ли выделенные объекты
    If ActiveSelection.Shapes.Count = 0 Then
        MsgBox "Пожалуйста, выделите объекты сначала.", vbExclamation, "Нет выделения"
        Exit Sub
    End If
    
    ' Начинаем операцию, которую можно отменить
    ActiveDocument.BeginCommandGroup "Outline to Fill Color"
    
    ' Перебираем все выделенные объекты
    For Each s In ActiveSelection.Shapes
        ' Проверяем, есть ли у объекта заливка
        If s.Fill.Type <> cdrNoFill Then
            ' Получаем цвет заливки
            Set fillColor = s.Fill.UniformColor
            
            ' Устанавливаем этот же цвет для абриса
          
            Set outlineColor = fillColor
            s.Outline.SetProperties Color:=outlineColor
          
        End If
    Next s
    
    ' Завершаем операцию
    ActiveDocument.EndCommandGroup
End Sub
 
  • Спасибо
Реакции: mnemonix
dastin сказал(а):
просто тарабарщина какая-то ...
лучше так
Код: 
Sub OutlineToFillColor()
    Dim s As Shape
    Dim fillColor As Color
    Dim outlineColor As Color
    
    ' Проверяем, есть ли выделенные объекты
    If ActiveSelection.Shapes.Count = 0 Then
        MsgBox "Пожалуйста, выделите объекты сначала.", vbExclamation, "Нет выделения"
        Exit Sub
    End If
    
    ' Начинаем операцию, которую можно отменить
    ActiveDocument.BeginCommandGroup "Outline to Fill Color"
    
    ' Перебираем все выделенные объекты
    For Each s In ActiveSelection.Shapes
        ' Проверяем, есть ли у объекта заливка
        If s.Fill.Type <> cdrNoFill Then
            ' Получаем цвет заливки
            Set fillColor = s.Fill.UniformColor
            
            ' Устанавливаем этот же цвет для абриса
          
            Set outlineColor = fillColor
            s.Outline.SetProperties Color:=outlineColor
          
        End If
    Next s
    
    ' Завершаем операцию
    ActiveDocument.EndCommandGroup
End Sub
Нажмите, чтобы раскрыть...
Почему-то в какой то момент редактор VBA стал странно работать с кодировками. Это скопировано из редактора VBA, править мне было, честно говоря, лень.
Вообще, это deepseek написал, правда, 3-4 строчки я поправил
 
MrDesigner сказал(а):

Не по теме:


Перед копированием надо было переключиться на русский язык. Не?
Нажмите, чтобы раскрыть...
В смысле? В редакторе все по-русски. Там с кодировками что-то, а ничего вроде notepad++ под рукой не было. Кракозябры вклеились уже здесь, в сообщении, в редакторе VBA все норм.
Кстати, если включить там русскую раскладку и попытаться что-то ввести, то тоже не смешно.
Upd: а тут еще и на обед пора ехать было...
 
Последнее редактирование:
dastin сказал(а):
просто тарабарщина какая-то ...
лучше так
Код: 
Sub OutlineToFillColor()
    Dim s As Shape
    Dim fillColor As Color
    Dim outlineColor As Color
   
    ' Проверяем, есть ли выделенные объекты
    If ActiveSelection.Shapes.Count = 0 Then
        MsgBox "Пожалуйста, выделите объекты сначала.", vbExclamation, "Нет выделения"
        Exit Sub
    End If
   
    ' Начинаем операцию, которую можно отменить
    ActiveDocument.BeginCommandGroup "Outline to Fill Color"
   
    ' Перебираем все выделенные объекты
    For Each s In ActiveSelection.Shapes
        ' Проверяем, есть ли у объекта заливка
        If s.Fill.Type <> cdrNoFill Then
            ' Получаем цвет заливки
            Set fillColor = s.Fill.UniformColor
           
            ' Устанавливаем этот же цвет для абриса
         
            Set outlineColor = fillColor
            s.Outline.SetProperties Color:=outlineColor
         
        End If
    Next s
   
    ' Завершаем операцию
    ActiveDocument.EndCommandGroup
End Sub
Нажмите, чтобы раскрыть...
ЧатГПТ хорохо справляется с кореловскими макросами. Рабочие варианты предлагает, которые можно доводить до ума...
Пробовал КВИН и ГигаЧат - они придумывают какие-то несуществующие методы и как правило не рабочие конструкции.
 
dastin сказал(а):
1251 улетает в 1252 - а там персы со своими письменами
Нажмите, чтобы раскрыть...
да. Особенно забавно начать набирать кириллицу в редакторе vba. Причем в более ранних версиях все было нормально
1749029675871.png
 
zollinger сказал(а):
Особенно забавно начать набирать кириллицу в редакторе vba
Нажмите, чтобы раскрыть...
самое простое начни не в редакторе, а на странице макета - а уже потом копируй в редактор ... и используй как шаблон
 
dastin сказал(а):
у wOxxOma спёр небось
Нажмите, чтобы раскрыть...
Я точно нет, а про deeppseek не скажу.
Но судя по ошибкам, он сам писал
1749030813932.png

dastin сказал(а):
самое простое начни не в редакторе, а на странице макета - а уже потом копируй в редактор ... и используй как шаблон
Нажмите, чтобы раскрыть...
Да ой
 
iKoolk сказал(а):
Бодрый день, коллеги!
Собственно, ищу макрос покраски абриса в цвет заливки. Знаю точно такой есть. Писать сейчас некогда.

Поделитесь, пожалуйста
Нажмите, чтобы раскрыть...
в моём докере есть такой функционал. как заливку по абрису, так и наоборот. абрис по заливке.
А так же можно просто разукрасить все объекты в разный цвет )
 
Для ответа нужно войти/зарегистрироваться
Верх Низ