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

[MrDesigner]

так получилось ... у Михаила лаконичней

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

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

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_]

Еще один штрих старого перфекциониста: конструкция ActiveDocument.ToUnits(-15, cdrMillimeter) некошерна. Гораздо правильнее в начале процедуры делать
ActiveDocument.Unit = cdrMillimeter
а потом просто писать
s.RightX -150, s.BottomY +15

 

[MrDesigner]

ыы!

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

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

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_]

Да не заморачивайся

 

[MrDesigner]

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

 

[_MBK_]

имя файла без расширения возможно публиковать?

Конечно можно. Отрезай последние 4 символа через Left
Хотя кошерно было бы искать символ "." а потом отрезать все что за ним

 

[dastin]

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

Недавно было

 

[dastin]

заметём в кучу

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

 

[MrDesigner]

заметём в кучу

Куча хороша!!! Работает, спасибо!

 

[MrDesigner]

Господа, помогите, плз.

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

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

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

Спасибо!

 

[MrDesigner]

 

[Drawer]

Лень лезть в референс корела, но наугад такое не прокатит?

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]

Лень лезть в референс корела, но наугад такое не прокатит?

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]

Координаты для

ну да - цапа тут

(s.LeftX + 150, s.TopY - 15, imya, , , "Tahoma", 24, Alignment:=cdrLeftAlignment)

точка старта и выравнивание текста

 

[MrDesigner]

ну да - цапа тут

точка старта и выравнивание текста

Да, спасибо, на работе уже отредактировал, как надо. Всё ок, работает.

 

[MrDesigner]

Преамбула. Если кому интересно. Решил потестить 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]

Амбула. Попросил ChatGPT рассказать, что делает этот код, и можно ли его оптимизировать.

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

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

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

Теперь давайте посмотрим на возможные ошибки и возможные оптимизации:

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

 

[MrDesigner]

Вот исправленный и оптимизированный вариант макроса:

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

 

[MrDesigner]

Проверил - работает. Ура! ))

 

[_MBK_]

Однако, научили!