[CDR 2024] Автоматическое переименование файлов

[Иван 1965]

В итоге сработало как вариант от deepseek, но почему-то не сохраняет в 2 из 3 случаев, после удаления старых файлов из папки при таком же названии он просто не сохраняет и ошибки не выдает

 

[Griffin_kk]

подскажите.... сделал запись сценария, всё как мне надо, но не знаю как изменить так, чтобы файл сохранялся с префикосм и в той же папке

Sub na_sborku()
' Recorded 04.09.2025
Dim SaveOptions As StructSaveAsOptions
Dim originalName As String
Dim fileNameWithoutExt As String
Dim newFileName As String
Dim prefix As String

prefix = "v13 curv в работу "
originalName = ActiveDocument.Name

' Извлекаем имя файла без расширения
If InStr(originalName, ".") > 0 Then
fileNameWithoutExt = Left(originalName, InStrRev(originalName, ".") - 1)
Else
fileNameWithoutExt = originalName
End If

' Используем ваш оригинальный путь, но меняем только имя файла
newFileName = "D:\work\2025\" & prefix & fileNameWithoutExt & ".cdr"

Set SaveOptions = CreateStructSaveAsOptions
With SaveOptions
.EmbedVBAProject = False
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = False
.Version = cdrVersion22
.KeepAppearance = True
End With

' Сохраняем с префиксом
ActiveDocument.SaveAs newFileName, SaveOptions

' Преобразуем в кривые
ActivePage.Shapes.All.CreateSelection
ActiveSelection.ConvertToCurves

' Сохраняем в версии 13
Set SaveOptions = CreateStructSaveAsOptions
With SaveOptions
.EmbedVBAProject = False
.Filter = cdrCDR
.IncludeCMXData = False
.Range = cdrAllPages
.EmbedICCProfile = False
.Version = cdrVersion13
.KeepAppearance = True
End With

ActiveDocument.SaveAs newFileName, SaveOptions
ActiveDocument.Close

MsgBox "Файл сохранен как: " & newFileName, vbInformation
End Sub

помогите с кодом, как заменить путь к папке на то, чтобы мой файл ТАБЛИЧКА, сохранялся например как ТАБЛИЧКА v13 curv в работу" в той же папке, где и находится исходник

deepseek эту задачу решить не может.... корел ругается постоянно... то на fullPath = ActiveDocument.FullName, то на .Version = cdrVersion13

 

[zollinger]

У меня на работе такая сохранялка есть. Если никто не напишет, утром скину

 

[zollinger]

Sub zpxSave13()
Optimization = True
    EventsEnabled = False
Dim Path As String
    NameVer = "_V13.cdr"
    NameVerLen = Len(NameVer)
    CdrLen = Len(".cdr")
    
    Dim Name As String
    Path = ActiveDocument.FilePath
    Name = ActiveDocument.FileName
    If Right(Name, Len(NameVer)) <> NameVer Then
         Name = Left(Name, Len(Name) - CdrLen) + NameVer
    End If
    
    Dim SaveOptions As StructSaveAsOptions
    Set SaveOptions = CreateStructSaveAsOptions
    With SaveOptions
        .EmbedVBAProject = False
        .Filter = cdrCDR
        .IncludeCMXData = False
        .Range = cdrAllPages
        .EmbedICCProfile = False
        .Version = cdrVersion13
        .KeepAppearance = True
      End With
    ActiveDocument.SaveAs Path + Name, SaveOptions
EventsEnabled = True
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
End Sub

 

[Griffin_kk]

Sub zpxSave13()
Optimization = True
    EventsEnabled = False
Dim Path As String
    NameVer = "_V13.cdr"
    NameVerLen = Len(NameVer)
    CdrLen = Len(".cdr")
   
    Dim Name As String
    Path = ActiveDocument.FilePath
    Name = ActiveDocument.FileName
    If Right(Name, Len(NameVer)) <> NameVer Then
         Name = Left(Name, Len(Name) - CdrLen) + NameVer
    End If
   
    Dim SaveOptions As StructSaveAsOptions
    Set SaveOptions = CreateStructSaveAsOptions
    With SaveOptions
        .EmbedVBAProject = False
        .Filter = cdrCDR
        .IncludeCMXData = False
        .Range = cdrAllPages
        .EmbedICCProfile = False
        .Version = cdrVersion13
        .KeepAppearance = True
      End With
    ActiveDocument.SaveAs Path + Name, SaveOptions
EventsEnabled = True
    Optimization = False
    ActiveWindow.Refresh
    Application.Refresh
End Sub

премного благодарен

 

[dastin]

.Version = cdrVersion13

вот тут не всё так радужно ... в версиях > 2019 при SaveAs - "дно" = v15
м.б. CMX устроит "отца русской демократии"?

 

[zollinger]

ну фиг знает....

всё работает. Кнопочка у меня прям вытащена, и никаких проблем

как бы вот

 

[zollinger]

Залоговок в файле CDRDvrsn ненавязчиво намекает нам на сохранение в версии 13

 

[dastin]

ну фиг знает....

значит не 2019 ... точно я не помню ... в нескольких последних сохранить штатно в 13 версию уже не выходит

 

[zollinger]

Вполне может быть, это логично - нафига тянуть эти проблемы с совместимостью через десятилетия.
Кстати, буквально две недели назад был затык с этой темой.
Подготовили файл для печати коробок в сторонней типографии, там вырубка, золото, конгрев, полноцвет, и пантон. Нужен корел. Подготовили, всё аккуратно по слоям разложили. Отправили в 2020. типуха говорит - нам бы вресию корела пониже. Ок, не вопрос, как раз вот этим макросом сохранили, глянули, все на местах, отправили.
Оттуда пишут, а что где, а как, а почему... Не понял, там же прям в именах слоёв все расписано.
Открыл файл исходный - расписано. Открыл файл под 13 - а там Layer0, Layer1, Layer2. Слетели имена слоёв Преременовал эти слои, закрыл-открыл, всё на местах. Что почему - тайна...