PLACE NUMBERS FROM 1 TO 99.......AT MOSE CLICK X, Y COORDINATES

bhbp.bg2
over 1 year ago

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 1
3. 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 1

5.To stop macro I click on sample, created in step 1 or......one other action


Greetings!

  • 0 over 1 year ago

    To terminete macto just click out of page

    Sub 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
    Wend
    End Sub

  • 0 over 1 year ago

    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:

    1. Select your original label (can be multiple shapes, but should include exactly one text shape).
    2. Copy (Ctrl+C).
    3. Run the macro.
    4. Mouse click to paste (text will be updated with each paste operation).
    5. Esc to stop placing duplicates.

    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: