Hello,Please make a macro:
1. I write 7 and around the number circle as an example.2. I select the sample, created in step 13. I run macro1 /must be created/ 4. I click on page anywhere and at click point appears 8.The printout should look like the example created in step 1 5. I click on other place on same page or on other page and appear 9 The printout should look like the example created in step 15.To stop macro I click on sample, created in step 1 or......one other actionGreetings!
This has just a small modification made to another macro that I had already written to "paste where I click".
To use this, you would:
Sub JQ_Paste_Where_I_Click_Multi_Increment_Integer_Text() Dim dblX As Double Dim dblY As Double Dim lngShiftState As Long Dim blnGotClick As Boolean Dim blnDone As Boolean Dim sr As ShapeRange Dim sLabelText As Shape Dim lngNextIncrement As Long Const strMacroName = "Paste Where I Click Increment Integer Text" On Error GoTo ErrHandler If Not ActiveDocument Is Nothing Then If Not Application.Clipboard.Empty Then Do Until blnDone get_coordinates_from_click dblX, dblY, lngShiftState, 10, True, cdrCursorSmallcrosshair, blnGotClick If blnGotClick Then ActiveDocument.BeginCommandGroup "PWIC Incr Int" Set sr = ActiveLayer.PasteEx If sr.Count > 0 Then sr.SetPositionEx cdrCenter, dblX, dblY '----------------------------------- 'added to increment text label lngNextIncrement = lngNextIncrement + 1 Set sLabelText = sr.Shapes.FindShape(, cdrTextShape) sLabelText.Text.Story = CStr(CLng(sLabelText.Text.Story) + lngNextIncrement) '----------------------------------- End If ActiveDocument.EndCommandGroup Else blnDone = True End If Loop Else MsgBox "Clipboard is empty.", vbExclamation, strMacroName End If Else MsgBox "No document is active.", vbExclamation, strMacroName End If ExitSub: If blnGotClick Then ActiveDocument.EndCommandGroup Refresh End If Exit Sub ErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSub End Sub Sub get_coordinates_from_click(ByRef ClickX As Double, ByRef ClickY As Double, ByRef ShiftState As Long, ByVal Timeout As Long, ByVal Snap As Boolean, ByVal CursorShape As cdrCursorShape, ByRef ClickMade As Boolean) Dim dblClickX As Double Dim dblClickY As Double Dim lngShiftState As Long Dim blnCancelled As Boolean blnCancelled = True blnCancelled = ActiveDocument.GetUserClick(dblClickX, dblClickY, lngShiftState, Timeout, Snap, CursorShape) If blnCancelled = False Then ClickX = dblClickX ClickY = dblClickY ShiftState = lngShiftState ClickMade = True Else ClickMade = False End If End Sub
Here is a video showing what it looks like in use:
Be aware that the modifications I made to this macro do not have any "safety features". It does not check to see that you have exactly one text shape, or that the text represents an integer number.
Hello, There are several valuable techniques in this macro. Thank you for the guidance. The macro doesn't work as I need it to,but that's because I'm trying it with Corel X3 - a rather archaic version, but it works solidly and serves me well. I'll have to make some tweaks to get things working in Corel X3. I will try it later with Corel X5 and Corel X8. I'll probably have to make some changes there too.Greetings!
I created that macro in X7, so it should work in X8.
Here it worked on 2022/23 without errors, perfect. Would you authorize me to make it available on the @corelnaveia Channel? The other day I was behind a process like that, how wonderful is that my noble! You are too much! srsr
Léo Silveira said:Would you authorize me to make it available on the @corelnaveia Channel?
Hello, Léo!
Yes, you may share this on your channel. Thank you for asking!
Here is a version where I have added a few tests to check if the pasted content contains text that represents an integer. So, it is a little bit more safe!
Sub JQ_Paste_Where_I_Click_Multi_Increment_Integer_Text() Dim dblX As Double Dim dblY As Double Dim lngShiftState As Long Dim blnGotClick As Boolean Dim blnDone As Boolean Dim sr As ShapeRange Dim sLabelText As Shape Dim lngNextIncrement As Long Const strMacroName = "Paste Where I Click Increment Integer Text" On Error GoTo ErrHandler If Not ActiveDocument Is Nothing Then If Not Application.Clipboard.Empty Then Do Until blnDone get_coordinates_from_click dblX, dblY, lngShiftState, 10, True, cdrCursorSmallcrosshair, blnGotClick If blnGotClick Then ActiveDocument.BeginCommandGroup "PWIC Incr Int" Set sr = ActiveLayer.PasteEx If sr.Count > 0 Then sr.SetPositionEx cdrCenter, dblX, dblY '----------------------------------- 'added to increment text label lngNextIncrement = lngNextIncrement + 1 Set sLabelText = sr.Shapes.FindShape(, cdrTextShape) If sLabelText Is Nothing Then MsgBox "No text shape was found in the pasted objects.", vbCritical, strMacroName GoTo ExitSub Else If Not IsNumeric(sLabelText.Text.Story) Then MsgBox "A text shape was found in the pasted objects, but it does not represent a numeric value.", vbCritical, strMacroName GoTo ExitSub Else If CLng(sLabelText.Text.Story) <> CDbl(sLabelText.Text.Story) Then MsgBox "A text shape was found in the pasted objects, but it does not represent an integer.", vbCritical, strMacroName GoTo ExitSub Else sLabelText.Text.Story = CStr(CLng(sLabelText.Text.Story) + lngNextIncrement) End If End If End If '----------------------------------- End If ActiveDocument.EndCommandGroup Else blnDone = True End If Loop Else MsgBox "Clipboard is empty.", vbExclamation, strMacroName End If Else MsgBox "No document is active.", vbExclamation, strMacroName End If ExitSub: If blnGotClick Then ActiveDocument.EndCommandGroup Refresh End If Exit Sub ErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSub End Sub Sub get_coordinates_from_click(ByRef ClickX As Double, ByRef ClickY As Double, ByRef ShiftState As Long, ByVal Timeout As Long, ByVal Snap As Boolean, ByVal CursorShape As cdrCursorShape, ByRef ClickMade As Boolean) Dim dblClickX As Double Dim dblClickY As Double Dim lngShiftState As Long Dim blnCancelled As Boolean blnCancelled = True blnCancelled = ActiveDocument.GetUserClick(dblClickX, dblClickY, lngShiftState, Timeout, Snap, CursorShape) If blnCancelled = False Then ClickX = dblClickX ClickY = dblClickY ShiftState = lngShiftState ClickMade = True Else ClickMade = False End If End Sub
Hey John,
This is a really handy macro.
Is there anyway of holding a leading zero between 01 to 09?
Thanks,
Cheers mate!
Chris said:Is there anyway of holding a leading zero between 01 to 09?
There is, and that's a good idea!
In this version, I use Format to do that, and the string that defines the formatting is "0#".
If you change that to "00#", then it gives three digits, with leading zeros as necessary.
If you change that to "#", then it works as the earlier version of the macro, with no leading zeros.
Sub JQ_Paste_Where_I_Click_Multi_Increment_Integer_Text_1_Digit_Leading_Zero() Dim dblX As Double Dim dblY As Double Dim lngShiftState As Long Dim blnGotClick As Boolean Dim blnDone As Boolean Dim sr As ShapeRange Dim sLabelText As Shape Dim lngNextIncrement As Long Const strMacroName = "Paste Where I Click Increment Integer Text" On Error GoTo ErrHandler If Not ActiveDocument Is Nothing Then If Not Application.Clipboard.Empty Then Do Until blnDone get_coordinates_from_click dblX, dblY, lngShiftState, 10, True, cdrCursorSmallcrosshair, blnGotClick If blnGotClick Then ActiveDocument.BeginCommandGroup "PWIC Incr Int" Set sr = ActiveLayer.PasteEx If sr.Count > 0 Then sr.SetPositionEx cdrCenter, dblX, dblY '----------------------------------- 'added to increment text label lngNextIncrement = lngNextIncrement + 1 Set sLabelText = sr.Shapes.FindShape(, cdrTextShape) If sLabelText Is Nothing Then MsgBox "No text shape was found in the pasted objects.", vbCritical, strMacroName GoTo ExitSub Else If Not IsNumeric(sLabelText.Text.Story) Then MsgBox "A text shape was found in the pasted objects, but it does not represent a numeric value.", vbCritical, strMacroName GoTo ExitSub Else If CLng(sLabelText.Text.Story) <> CDbl(sLabelText.Text.Story) Then MsgBox "A text shape was found in the pasted objects, but it does not represent an integer.", vbCritical, strMacroName GoTo ExitSub Else sLabelText.Text.Story = Format(CLng(sLabelText.Text.Story) + lngNextIncrement, "0#") End If End If End If '----------------------------------- End If ActiveDocument.EndCommandGroup Else blnDone = True End If Loop Else MsgBox "Clipboard is empty.", vbExclamation, strMacroName End If Else MsgBox "No document is active.", vbExclamation, strMacroName End If ExitSub: If blnGotClick Then ActiveDocument.EndCommandGroup Refresh End If Exit Sub ErrHandler: MsgBox "Error occurred: " & Err.Description Resume ExitSub End Sub Sub get_coordinates_from_click(ByRef ClickX As Double, ByRef ClickY As Double, ByRef ShiftState As Long, ByVal Timeout As Long, ByVal Snap As Boolean, ByVal CursorShape As cdrCursorShape, ByRef ClickMade As Boolean) Dim dblClickX As Double Dim dblClickY As Double Dim lngShiftState As Long Dim blnCancelled As Boolean blnCancelled = True blnCancelled = ActiveDocument.GetUserClick(dblClickX, dblClickY, lngShiftState, Timeout, Snap, CursorShape) If blnCancelled = False Then ClickX = dblClickX ClickY = dblClickY ShiftState = lngShiftState ClickMade = True Else ClickMade = False End If End Sub