[CDR 2017-2021] Вставка имени файла в документ

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
так получилось ... у Михаила лаконичней :)

Уф. Какие-то глюки у меня, что ли...

Вот, всё работает, всем спасибо!

Код:
Sub InsertFileName()
    Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
    Set txt = ActiveLayer.CreateArtisticText(s.RightX - ActiveDocument.ToUnits(150, cdrMillimeter), _
    s.BottomY - ActiveDocument.ToUnits(-15, cdrMillimeter), ActiveDocument.FileName, , , "Tahoma", _
    24, Alignment:=cdrRightAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Еще один штрих старого перфекциониста: конструкция ActiveDocument.ToUnits(-15, cdrMillimeter) некошерна. Гораздо правильнее в начале процедуры делать
ActiveDocument.Unit = cdrMillimeter
а потом просто писать
s.RightX -150, s.BottomY +15
 
  • Спасибо
Реакции: zollinger и dastin

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
ыы!

Как правильно код должен быть написан, подскажите, плз?

С учётом моих правок, сейчас рабочий этот:

Код:
Sub InsertFileName()
    Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
    Set txt = ActiveLayer.CreateArtisticText _
    (s.RightX - ActiveDocument.ToUnits(150, cdrMillimeter), _
    s.BottomY - ActiveDocument.ToUnits(-15, cdrMillimeter), _
    ActiveDocument.FileName, , , "Tahoma", 24, Alignment:=cdrRightAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Да не заморачивайся
 

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Во. Ещё одна "хотелка": имя файла без расширения возможно публиковать? Или тут уже сложности?
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
имя файла без расширения возможно публиковать?
Конечно можно. Отрезай последние 4 символа через Left
Хотя кошерно было бы искать символ "." а потом отрезать все что за ним
 

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 216
Реакции
2 106
заметём в кучу :)

Код:
Sub InsertFileName()
ActiveDocument.Unit = cdrMillimeter
imya = ActiveDocument.FileName
imya = Left(imya, Len(imya) - 4) 
    Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
    Set txt = ActiveLayer.CreateArtisticText _
    (s.RightX - 150, s.BottomY +15, imya, , , "Tahoma", 24, Alignment:=cdrRightAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub
 
  • Спасибо
Реакции: tohaa, MrDesigner и _MBK_

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Господа, помогите, плз.

Есть чудесный макрос, который написал уважаемый @dastin, выводящий имя файла при активном выделенном объекте (шейпе) в правом нижнем углу этого объекта:

1716475673480.jpeg


Код:
Sub InsertFileName()
ActiveDocument.Unit = cdrMillimeter
imya = ActiveDocument.FileName
imya = Left(imya, Len(imya) - 4)
    Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
    Set txt = ActiveLayer.CreateArtisticText _
    (s.RightX - 150, s.BottomY + 15, imya, , , "Tahoma", 24, Alignment:=cdrRightAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub

Его же можно дополнить, чтобы имя файла дублировалось и в левом верхнем углу выделенного объекта (шейпа)?

Спасибо! ':=)'
 

Drawer

Участник
Сообщения
1 979
Реакции
890
Лень лезть в референс корела, но наугад такое не прокатит?:)
Код:
Sub InsertFileName()
ActiveDocument.Unit = cdrMillimeter
imya = ActiveDocument.FileName
imya = Left(imya, Len(imya) - 4)
    Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
    Set txt = ActiveLayer.CreateArtisticText _
    (s.RightX - 150, s.BottomY + 15, imya, , , "Tahoma", 24, Alignment:=cdrRightAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
    Set txt = ActiveLayer.CreateArtisticText _
    (s.LeftX + 150, s.TopY - 15, imya, , , "Tahoma", 24, Alignment:=cdrLeftAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub
 
  • Спасибо
Реакции: MrDesigner

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Лень лезть в референс корела, но наугад такое не прокатит?:)
Код:
Sub InsertFileName()
ActiveDocument.Unit = cdrMillimeter
imya = ActiveDocument.FileName
imya = Left(imya, Len(imya) - 4)
    Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
    Set txt = ActiveLayer.CreateArtisticText _
    (s.RightX - 150, s.BottomY + 15, imya, , , "Tahoma", 24, Alignment:=cdrRightAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
    Set txt = ActiveLayer.CreateArtisticText _
    (s.LeftX + 150, s.TopY - 15, imya, , , "Tahoma", 24, Alignment:=cdrLeftAlignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub
Работает! Координаты для верхней левой подписи чуть поправлю, спасибо!!!
 

dastin

Некромант-любитель
12 лет на форуме
Сообщения
2 216
Реакции
2 106
  • Спасибо
Реакции: MrDesigner

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Преамбула. Если кому интересно. Решил потестить ChatGPT на этом макросе.

Вот код в последней редакции (поправил координаты вывода имени файла в верхнем левом углу выделенного шейпера):

Код:
Sub InsertFileName()
ActiveDocument.Unit = cdrMillimeter
imya = ActiveDocument.FileName
imya = Left(imya, Len(imya) - 4)
   Set s = ActiveShape
   If s Is Nothing Then Beep: Exit Sub
  
   Set txt = ActiveLayer.CreateArtisticText _
   (s.RightX - 150, s.BottomY + 15, imya, , , "Tahoma", 24, Alignment:=cdrRightAlignment)
   txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
    
   Set txt = ActiveLayer.CreateArtisticText _
   (s.LeftX + 120, s.TopY - 23, imya, , , "Tahoma", 24, Alignment:=cdrLeftAlignment)
   txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
    
End Sub
 

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Амбула. Попросил ChatGPT рассказать, что делает этот код, и можно ли его оптимизировать.

Бездушная машина недолго думая написала:

Этот макрос выполняет следующие действия:

  1. Устанавливает единицы измерения в миллиметры для активного документа.
  2. Получает имя активного документа и удаляет расширение файла (.cdr) из имени.
  3. Создает два текстовых объекта: один выравнивается по правому краю, а другой по левому краю.
  4. Заполняет текстовые объекты именем файла без расширения.
  5. Устанавливает цвет текста в CMYK (0, 0, 0, 30).
Теперь давайте посмотрим на возможные ошибки и возможные оптимизации:

  1. В коде отсутствует проверка наличия активной формы (ActiveShape). Если форма отсутствует, код выдаст сигнал и прекратит выполнение. Это может быть нежелательным, если макрос предназначен для автоматизации, и необходимо принять другие меры, например, создать новую форму.
  2. В этом макросе активный текстовый объект назначается переменной txt, но после создания второго текстового объекта значение переменной перезаписывается. Таким образом, первый созданный текстовый объект не остается доступным для дальнейших манипуляций. Если это не то, что было намерено, нужно изменить названия переменных.
  3. Возможно, было бы более эффективно создать функцию или процедуру для создания текстового объекта, чтобы избежать повторения кода при создании двух текстовых объектов.
  4. Возможно, стоит добавить обработку исключений для обработки случаев, когда имя файла содержит специальные символы или пробелы, которые могут привести к ошибкам.
 

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Вот исправленный и оптимизированный вариант макроса:

Код:
Sub InsertFileName()
    ' Установка единиц измерения в миллиметры для активного документа
    ActiveDocument.Unit = cdrMillimeter
    
    ' Получение имени активного документа и удаление расширения файла (.cdr)
    Dim fileName As String
    fileName = Left(ActiveDocument.FileName, Len(ActiveDocument.FileName) - 4)
    
    ' Проверка наличия активной формы
    Dim s As Shape
    On Error Resume Next
    Set s = ActiveShape
    On Error GoTo 0
    If s Is Nothing Then
        MsgBox "Active shape is not selected.", vbExclamation
        Exit Sub
    End If
    
    ' Создание текстовых объектов
    CreateTextObject s.RightX - 150, s.BottomY + 15, fileName, cdrRightAlignment
    CreateTextObject s.LeftX + 120, s.TopY - 23, fileName, cdrLeftAlignment
End Sub

' Функция для создания текстового объекта
Sub CreateTextObject(x As Double, y As Double, text As String, alignment As cdrAlignment)
    Dim txt As Shape
    Set txt = ActiveLayer.CreateArtisticText(x, y, text, , , "Tahoma", 24, Alignment:=alignment)
    txt.Fill.UniformColor = CreateCMYKColor(0, 0, 0, 30)
End Sub
 
  • Спасибо
Реакции: izrukvruki

MrDesigner

Топикстартер
15 лет на форуме
Сообщения
2 112
Реакции
774
Проверил - работает. Ура! ))
 

_MBK_

Пикирующий бомбардировщик
15 лет на форуме
Сообщения
33 361
Реакции
10 886
Однако, научили! 'cooll)'
 
  • Спасибо
Реакции: MrDesigner