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

  • Автор темы Автор темы MrDesigner
  • Дата начала Дата начала
dastin сказал(а):
так получилось ... у Михаила лаконичней :)
Нажмите, чтобы раскрыть...

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

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

Код: 
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
 
Еще один штрих старого перфекциониста: конструкция ActiveDocument.ToUnits(-15, cdrMillimeter) некошерна. Гораздо правильнее в начале процедуры делать
ActiveDocument.Unit = cdrMillimeter
а потом просто писать
s.RightX -150, s.BottomY +15
 
  • Спасибо
Реакции: zollinger и dastin
ыы!

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

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

Код: 
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
 
Да не заморачивайся
 
Во. Ещё одна "хотелка": имя файла без расширения возможно публиковать? Или тут уже сложности?
 
MrDesigner сказал(а):
имя файла без расширения возможно публиковать?
Нажмите, чтобы раскрыть...
Конечно можно. Отрезай последние 4 символа через Left
Хотя кошерно было бы искать символ "." а потом отрезать все что за ним
 
заметём в кучу :)

Код: 
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_
Господа, помогите, плз.

Есть чудесный макрос, который написал уважаемый @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

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

Спасибо! ':=)'
 
Лень лезть в референс корела, но наугад такое не прокатит?:)
Код: 
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
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
Преамбула. Если кому интересно. Решил потестить 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
 
Амбула. Попросил ChatGPT рассказать, что делает этот код, и можно ли его оптимизировать.

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

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

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

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

Код: 
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
Проверил - работает. Ура! ))
 
Однако, научили! 'cooll)'
 
  • Спасибо
Реакции: MrDesigner
Для ответа нужно войти/зарегистрироваться
Верх Низ