How to Insert Shape at cursor position in MSWORD using VBA - vba

Question

I want to insert a shape in Word above the picture where ever user clicks.
I have written the program below, but sometimes it is placing the rectangle incorrectly and inserting it twice: once where I need it and again somewhere else.
Why is the Shape being inserted twice?
Private WithEvents app As Word.Application
Private Sub app_WindowSelectionChange(ByVal Sel As Selection)
Cancel = True
Call CurosrXY_Pixels
End SuB
Sub CurosrXY_Pixels()
ActiveDocument.Shapes.AddShape(msoShapeRectangle, fcnXCoord, fcnYCoord, 20#, 16#).Select
With Selection
.ShapeRange.TextFrame.TextRange.Select
.Collapse
.Font.Name = "Arial"
.Font.Size = 7
.Font.Bold = False
.Paragraphs.FirstLineIndent = 0
.Paragraphs.RightIndent = -10
.Paragraphs.LeftIndent = -10
.Paragraphs.Alignment = wdAlignParagraphCenter
.TypeText Text:=11
.ShapeRange.LockAspectRatio = msoCTrue
End With
End Sub
Function fcnXCoord() As Double
fcnXCoord = Selection.Information(wdHorizontalPositionRelativeToPage)
End Function
Function fcnYCoord() As Double
fcnYCoord = Selection.Information(wdVerticalPositionRelativeToPage)
End Function

Answer 1

The reason the code is firing more than once is because of the use of the Select method. Code changing the selection is the same as the user doing so. The way to avoid this is to work directly with the Word objects.
The code below illustrates this in the procedure CurosrXY_Pixels. A Shape object is declared, then the newly inserted drawing object assigned to it. This then used for setting the formatting and text, in the With block.
Notice I've also passed the Selection object from the event to this procedure, as well as to the two that calculate the co-ordinates. Since, conceivably, the user could click again before the macro finishes, it's important to pass along the original Selection. (That the original code was not doing so probably contributed to the "randomness" of where things were being created since the code, itself, was changing the selection.)
The code line in the app_WindowSelectionChange event to call the other procedures: CurosrXY_Pixels Sel
Sub CurosrXY_Pixels(Sel As Word.Selection)
Dim shp As Word.Shape
Set shp = ActiveDocument.Shapes.AddShape(msoShapeRectangle, fcnXCoord(Sel), fcnYCoord(Sel), 20#, 16#, Sel.Range)
With shp.TextFrame.TextRange
.Font.Name = "Arial"
.Font.Size = 7
.Font.Bold = False
.Paragraphs.FirstLineIndent = 0
.Paragraphs.RightIndent = -10
.Paragraphs.LeftIndent = -10
.Paragraphs.Alignment = wdAlignParagraphCenter
.Text = 11
End With
shp.LockAspectRatio = msoCTrue
End Sub
Function fcnXCoord(Sel As Word.Selection) As Double
fcnXCoord = Sel.Information(wdHorizontalPositionRelativeToPage)
End Function
Function fcnYCoord(Sel As Word.Selection) As Double
fcnYCoord = Sel.Information(wdVerticalPositionRelativeToPage)
End Function