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
Thank you my friend,
Coding certainly in not my thing!
Cheers!
' Copia objetos com números e formas para o local do clique do mouse' By EskimoCorel, versão anterior!' Atualização bY Bruno Braga e @corelnaveia Vs2 de 2023 - FREE
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 = "JQ_PasteAtMouseIncrement" Dim incrementInput As Variant On Error GoTo ErrHandler ' Verifica se um documento está ativo e se há algo na área de transferência If ActiveDocument Is Nothing Then MsgBox "Nenhum documento está ativo.", vbExclamation, strMacroName Exit Sub End If ' Verifica se há um objeto selecionado If ActiveSelection.Shapes.Count <> 1 Then MsgBox "Nenhum item selecionado. Por favor, selecione um item agrupado antes de continuar.", vbExclamation, strMacroName Exit Sub Else ' Copia o objeto selecionado para a área de transferência ActiveDocument.Selection.Copy End If If Application.Clipboard.Empty Then MsgBox "A área de transferência está vazia.", vbExclamation, strMacroName Exit Sub End If ' Verifica se é a primeira vez que um item é colado e incrementa o valor apropriado If lngNextIncrement = 0 Then ' Verifica se o input do usuário é numérico Do incrementInput = InputBox("Por favor, insira um incremento desejado:", strMacroName, "1") If incrementInput = False Or incrementInput = "" Then ' O usuário pressionou "Cancelar" ou "X" na caixa de diálogo Exit Sub ElseIf Not IsNumeric(incrementInput) Or Val(incrementInput) < 1 Then MsgBox "Por favor, insira um número maior ou igual a 1.", vbExclamation, strMacroName Else Exit Do End If Loop Increment = Val(incrementInput) End If
' Loop principal Do Until blnDone ' Obtém as coordenadas do próximo clique do usuário get_coordinates_from_click dblX, dblY, lngShiftState, 10, True, cdrCursorSmallcrosshair, blnGotClick If blnGotClick Then
lngNextIncrement = lngNextIncrement + Increment ' Cola o item na posição do clique e incrementa a etiqueta de texto ActiveDocument.BeginCommandGroup "PWIC Incr Int" Set sr = ActiveLayer.PasteEx If sr.Count > 0 Then sr.SetPositionEx cdrCenter, dblX, dblY ' Incrementa a etiqueta de texto Set sLabelText = sr.Shapes.FindShape(, cdrTextShape) sLabelText.Text.Story = CStr(CLng(sLabelText.Text.Story) + lngNextIncrement) End If ActiveDocument.EndCommandGroup Else ' Se o usuário não clicou em nada, sai do loop principal blnDone = True End If Loop ExitSub: ' Finaliza o comando de colagem se necessário If blnGotClick Then ActiveDocument.EndCommandGroup Refresh End If Exit Sub
ErrHandler: MsgBox "Erro ocorrido: " & Err.Description Resume ExitSubEnd Sub
' Obtém o clique do usuário e atualiza as variáveis 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 SubPs: We took the liberty of making some changes before releasing the code update, now we just need to select the shapes and call the macro which will already go to the clipboard and we put some error checks,when nothing is selected and when an invalid value is entered as well as when there is nothing in the clipboard, I hope you like it, this way seems to be fine, but your opinion is always welcome my dear! Success there and grateful for always helping us!