Can You Automate Numbering Pages/ Graphics?

Hello, everybody!

The fact is that this problem remains as relevant as it was 13 years ago. Especially for people working with older versions of CorelDraw. With the newer ones, I don't know if the topic has developed and if Mail merge has achieved the ease and intuitiveness of that of MS Word, MS Excel.

In older versions, VBA allows this gap to be filled. Because of the above, I am taking the liberty of offering a code for numbering coupons, tickets, coupons, etc. again. I am offering a modified code that is based on an older one of mine, but in this case it only numbers in one place on the coupon. This is the easier task. I can confidently say that VBA makes it possible to realize almost any user fantasy. I hope this code is useful for you. The code is not perfect and can be improved. Any suggestions or ideas would be gratefully received. The code will be especially useful for people interested in VBA and CorelDRAW's Document Object Model. For it to work, two of the coupons need to be located at the top of the first sheet next to each other. Each coupon has 0000 /Null Null Null Null/ entered, indicating where the automatic numbering will be located. After selecting the two coupons together with their numbers, the program starts. Somewhere in the beginning there is a MsgBox "Resume" that overcomes an unexpected error. Without the MsgBox "Resume" the program does not perform the task as expected. This is in Corel X5.

'TO WORK THIS CODE MUST:
'HAVE 2 TICKETS ON PAGE 1 NEAR AT TOP MARGIN

'EVERY TICKET MUST HAVE 1 NUM FIELDS / NUMERIC TEXT
'THE TICKETS MUST BE SELECTED

'LOCKED OBJECT CAN NOT BE DUPLICATED
'IF LAYER IS LOCKED FOR EDITING - IT CAN
'IF LAYER IS LOCKED CAN NOT SELECT OBJECTS ON IT
ActiveSelection.Shapes.All.Group
PAGES_COUNT = ActiveDocument.Pages.Count
If ActiveDocument.Pages.Count > 1 Then
For X = 2 To PAGES_COUNT
ActiveDocument.Pages(2).Delete
Next
End If
Dim AAA, BBB As Shape
ActiveDocument.Pages(1).Shapes(1).MoveToLayer ActiveDocument.Pages(1).Layers("Layer 1")
Set AAA = ActiveDocument.ActivePage.Layers("Layer 1").Shapes(1).Duplicate(0, -ActiveDocument.ActivePage.Layers("Layer 1").Shapes(1).SizeHeight)

For X = 1 To 2
Set AAA = AAA.Duplicate(0, -AAA.SizeHeight) 'not work if locked
Next

With ActiveDocument.Pages(1).Shapes.All
.Group
.Copy
End With

ActiveDocument.Pages(1).Shapes(1).MoveToLayer ActiveDocument.Pages(1).Layers("Layer 1")

ActiveDocument.BeginCommandGroup "DELETE PAGES 2-5"
PAGE_COUNT = ActiveDocument.Pages.Count
If ActiveDocument.Pages.Count > 1 Then
For X = 2 To PAGES_COUNT
ActiveDocument.Pages(2).Delete
Next
End If
ActiveDocument.EndCommandGroup
tbTicketsTotal = 150
tbTicketsOnPage = 8
pages_tocreate = tbTicketsTotal / tbTicketsOnPage
ActiveDocument.AddPages (pages_tocreate - 1)

For X = 2 To ActiveDocument.Pages.Count

With ActiveDocument.Pages(X)
.Activate
.Layers("Layer 1").Paste
End With

Next
MsgBox "RESUME"

''paste on each page
For X = 2 To ActiveDocument.Pages.Count
ActiveDocument.Pages(X).Layers("Layer 1").Paste
Next

'ungroup all
Dim MPAGE As Page
For Each MPAGE In ActiveDocument.Pages
MPAGE.Shapes.All.UngroupAll
Next

'numbering
Dim DSHAPE As Shape
Dim DPAGE As Page

tbStart=600

FLAG1 = tbStart - 1
FLAG3 = 0

For Each DPAGE In ActiveDocument.Pages

For Each DSHAPE In DPAGE.Shapes

If DSHAPE.Type = 6 Then 'text

FLAG1 = FLAG1 + 1

VCENTERX = DSHAPE.CenterX
VCENTERY = DSHAPE.CenterY

tbNumPosition = 4
For X = 1 To tbNumPosition
zerostring = zerostring & "0"
Next

If tbNumPosition = 1 Then
DSHAPE.Text.Range(0, 1000) = Format(FLAG1, "0")
End If
If tbNumPosition = 2 Then
DSHAPE.Text.Range(0, 1000) = Format(FLAG1, "00")
End If
If tbNumPosition = 3 Then
DSHAPE.Text.Range(0, 1000) = Format(FLAG1, "000")
End If
If tbNumPosition = 4 Then
DSHAPE.Text.Range(0, 1000) = Format(FLAG1, "0000")
End If
If tbNumPosition = 5 Then
DSHAPE.Text.Range(0, 1000) = Format(FLAG1, "00000")
End If

tbSize = 20
DSHAPE.Text.Range(0, 100).Size = tbSize

DSHAPE.CenterX = VCENTERX
DSHAPE.CenterY = VCENTERY
End If
Next
Next

End Sub

Final result: