[CDR 2017-2021] Увеличение цифры в файле при каждом запуске макроса.

[tohaa]

Добрый день уважаемые товарищи. Помогите решить такую задачу.

Макрос добавляет номер (например 00) на страницу документа.

Нужно, чтобы при наличии номера на странице (уже есть 00), рядом добавлялся номер на 1 больше существующего(00, 01...).

Старый номер должен остаться.

 

[_MBK_]

при наличии номера на странице

А как отличить номер от всех иных прочих текстовых объектов на странице?

 

[tohaa]

А как отличить номер от всех иных прочих текстовых объектов на странице?

Видимо дать объекту имя, сосчитать количество одинаковых имен на странице и добавить 1 к этой цифре. Вот как это написать в макрос я не представляю.

 

[_MBK_]

сосчитать количество одинаковых имен на странице

Брр а разве на странице может быть много номеров? Вдобавок, как быть, если номер уже поставлен рядом - это будет номер или уже не номер и нужно ставить другой номер на то же место?
Вы для начала хотя бы ТЗ внятно сформулируйте
К тому же, мне непонятна сама суть вопроса - вы пишете макрос сами и в гдето споткнулись (в каком конкретно месте?) или, по традициям этого форума, хотите отдать его на краудсорсинг, надеясь, что вам и техзадание в процессе доделают?

 

[lev]

Sub plus1()
  On Error Resume Next
  max = -100
  For Each t In ActivePage.Shapes.FindShapes(, cdrTextShape)
    d = CInt(t.Text.Story)
    If d > max Then max = d
  Next t
  ActiveLayer.CreateArtisticText 0, 0, CStr(max + 1)
End Sub

 

[_MBK_]

при наличии номера на странице (уже есть 00), рядом добавлялся номер на 1 больше существующего(

 

[dastin]

рядом добавлялся номер на 1 больше

не рядом - а на невидимый специальный слой - и имя и число будет меняться на +1

        Sub NameCount()
    Dim NameMax As String, Countr As Integer, Lay As Layer, shN As Shape
    For Each Lay In ActiveDocument.ActivePage.Layers
        If Lay.Name = "Number" Then
                Countr = ActivePage.Layers("Number").Shapes.Count
                NameMax = CStr(Countr)
                Set shN = ActivePage.ActiveLayer.CreateArtisticText(0, 0, "0" & NameMax)
                shN.Name = "0" & NameMax
                ActivePage.Layers("Number").Visible = False
                Exit Sub
        End If
    Next Lay
            ActiveDocument.ActivePage.CreateLayer "Number"
            ActivePage.Layers("Number").Activate
            ActivePage.Layers("Number").Visible = False
            Set shN = ActivePage.ActiveLayer.CreateArtisticText(0, 0, "00")
            shN.Name = "00"
 
    End Sub

 

[tohaa]

Sub plus1()
  On Error Resume Next
  min = -100
  For Each t In ActivePage.Shapes.FindShapes(, cdrTextShape)
    d = CInt(t.Text.Story)
    If d > min Then min = d
  Next t
  ActiveLayer.CreateArtisticText 0, 0, CStr(min + 1)
End Sub

Гениально) Спасибо большое!

 

[tohaa]

Sub plus1()
  On Error Resume Next
  max = -100
  For Each t In ActivePage.Shapes.FindShapes(, cdrTextShape)
    d = CInt(t.Text.Story)
    If d > max Then max = d
  Next t
  ActiveLayer.CreateArtisticText 0, 0, CStr(max + 1)
End Sub

Доброе утро. Подскажите как добавить текущую дату перед добавляемой цифрой? Например "11.02.21_0", "11.02.21_1"...

 

[_MBK_]

Наверное

Sub plus1()
  On Error Resume Next
  max = -100
  For Each t In ActivePage.Shapes.FindShapes(, cdrTextShape)
    d = CInt(t.Text.Story)
    If d > max Then max = d
  Next t
  ActiveLayer.CreateArtisticText 0, 0, Date() & "_" & CStr(max + 1)
End Sub

 

[tohaa]

Наверное

Sub plus1()
  On Error Resume Next
  max = -100
  For Each t In ActivePage.Shapes.FindShapes(, cdrTextShape)
    d = CInt(t.Text.Story)
    If d > max Then max = d
  Next t
  ActiveLayer.CreateArtisticText 0, 0, Date() & "_" & CStr(max + 1)
End Sub

При таком написании цифра не изменяется. Не могу понять почему. Сразу же попробовал.

 

[_MBK_]

Чтото делаете не так, только что проверил, работает

 

[tohaa]

Чтото делаете не так, только что проверил, работает

Только два запуска отрабатывает. первое значение -99, затем 1. и всё. Мне нужны значения 0+. Без даты работает.

 

[tohaa]

 

[_MBK_]

А, вот вы о чем
Так тогда постановка задачи сама себе противоречит - 11.02.2021_1 по понятным причинам уже не будет номером

 

[tohaa]

В общем, пришлось дату создавать отдельным объектом и ровнять к номеру.

 

[_MBK_]

Sub plus1()
  dim dt as Shape
  On Error Resume Next
  max = -100
  For Each t In ActivePage.Shapes.FindShapes(, cdrTextShape)
    d = CInt(t.Text.Story)
    If d > max Then max = d
  Next t
  set dt= ActiveLayer.CreateArtisticText( 0, 0, Date())
  ActiveLayer.CreateArtisticText dt.SizeWidth+10, 0, CStr(max + 1)
End Sub

 

[tohaa]

А можно я ещё немножко усложню задачу?)

Как сделать, чтобы поиск номеров, при запуске макроса, происходил только среди номеров добавленных этим макросом?

Сейчас макрос отлично работает пока не встретится какой-то номер в тексте.

 

[lev]

Можно при создании именовать объекты

ActiveLayer.CreateArtisticText( 0, 0, "100").Name="Numb"

И поиск проводить уже только среди именованных

For Each t In ActivePage.Shapes.FindShapes("Numb")