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!
To terminete macto just click out of pageSub From1To99() Dim s As Shape, s1 As Shape Dim i%, X As Double, Y As Double, pause% Dim Shift As Long, b As Boolean, SR_New As ShapeRange ActiveDocument.Unit = cdrMillimeter pause = 10 b = False While Not b i = i + 1 b = ActiveDocument.GetUserClick(X, Y, Shift, pause, False, cdrCursorSmallcrosshair) If X > ActivePage.LeftX And X < ActivePage.RightX Then If Y > ActivePage.BottomY And Y < ActivePage.TopY Then Set SR_New = New ShapeRange Set s = ActiveLayer.CreateEllipse2(X, Y, 10, 10) SR_New.Add s Set s1 = ActiveLayer.CreateArtisticText(X, Y, i) ', , , fntNm) SR_New.Add s1 s1.CenterX = s.CenterX s1.CenterY = s.CenterY SR_New.Group ActiveDocument.ClearSelection Else b = True End If Else b = True End If If i = 99 Then b = True WendEnd Sub
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:
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)
blnDone = True
MsgBox "Clipboard is empty.", vbExclamation, strMacroName
MsgBox "No document is active.", vbExclamation, strMacroName
If blnGotClick Then
MsgBox "Error occurred: " & Err.Description
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
ClickMade = False
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.
Thanks for the reply!
There are some valuable things in this macro, but it doesn't work the way I need it to, namely:
If the group we created containing a number in a circle or square or rectangle etc. contains the number 3, then on the first mouse click the next group should contain 4, i.e. +1 from the number of the original. In this sense, the 99 limit is redundant.
Second - each subsequent group should look like the first, this is our pattern - font, size, color, etc.
Здравейте,Благодаря за отговора!Има някои ценни неща в този макрос, но той не работи както ми трябва, а именно:Ако създадената от нас група, съдържаща цифра в кръг или квадрат или правоъгълник и т.н. съдържа цифра 3, то при първото щракане с мишката следващата група трябва да съдържа 4, т.е. +1 от числото на оригинала. В този смисъл ограничението 99 е излишно. Второ - всяка следваща група трябва да изглежда както първата, това е нашият образец - шрифт, размер, цвят и т.н.
Sub DulpicateToClick() Dim s As Shape, s1 As Shape, SR As ShapeRange Dim i%, X As Double, Y As Double, pause% Dim Shift As Long, b As Boolean, SR_New As ShapeRange
ActiveDocument.Unit = cdrMillimeter pause = 10 Set SR = ActiveSelectionRange For Each s In SR If s.Type = cdrTextShape Then i = Int(s.Text.Story.Text) Exit For End If Next s s.RemoveFromSelection Set SR = ActiveSelectionRange b = False While Not b i = i + 1 b = ActiveDocument.GetUserClick(X, Y, Shift, pause, False, cdrCursorSmallcrosshair) If X > ActivePage.LeftX And X < ActivePage.RightX Then If Y > ActivePage.BottomY And Y < ActivePage.TopY Then Set SR_New = SR.Duplicate Set s1 = s.Duplicate s1.Text.Story.Text = i s1.CenterX = X s1.CenterY = Y SR.CenterX = X SR.CenterY = Y ActiveDocument.ClearSelection Else b = True End If Else b = True End If If i = 99 Then b = True WendEnd Sub
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!