none
Macro for inserting a shape into Word 2010 Document RRS feed

  • Question

  • I am constantly generating reports with pictures. Browsing through forums, I have found a macro that will resize my pictures and place a border around them, saving me tons of time and for that I am very appreciative. I also insert arrows to identify the area of the picture that I am describing in my report. Currently that means clicking the shape (left arrow) and then resizing the arrow to fit it into the picture. Do anyone have any suggestions about how I might add the shape (color fill, outline, border and proper sizing) to my existing macro?

    Friday, September 7, 2012 10:04 PM

Answers

  • Perhaps something along the lines of:

    Sub FormatPicture()
    Dim shp As Word.Shape
    Dim ishp As Word.InlineShape
    Dim lWdth As Single, lHght As Single, lTop As Single, lLeft As Single
    Dim vAlignV, vAlignH, lArrW As Single, lArrH As Single
    lWdth = InchesToPoints(2.67): lHght = InchesToPoints(2)
    lArrW = InchesToPoints(1): lArrH = lArrW / 2
    With Word.Selection
      If .Type = wdSelectionInlineShape Then
        With .InlineShapes(1)
          .LockAspectRatio = False
          lLeft = .Range.Information(wdHorizontalPositionRelativeToPage)
          lTop = .Range.Information(wdVerticalPositionRelativeToPage)
          .Height = lHght
          .Width = lWdth
        End With
        Call AddArrow(lArrW, lArrW / 2, lTop + lHght / 8, lLeft)
      ElseIf .Type = wdSelectionShape Then
        With .ShapeRange
          .LockAspectRatio = False
          vAlignH = .RelativeHorizontalPosition
          vAlignV = .RelativeVerticalPosition
          .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
          .RelativeVerticalPosition = wdRelativeVerticalPositionPage
          .RelativeHorizontalPosition = vAlignH
          .RelativeVerticalPosition = vAlignV
          lLeft = .Left
          lTop = .Top
          .Height = lHght
          .Width = lWdth
        End With
        Call AddArrow(lArrW, lArrH, lTop + lHght / 3, lLeft)
      End If
    End With
    End Sub

    Sub AddArrow(lWdth As Single, lHght As Single, lTop As Single, lLeft As Single)
    Dim ShpArrow As Shape
    Set ShpArrow = ActiveDocument.Shapes.AddShape(msoShapeRightArrow, _
      Top:=lTop, Left:=lLeft, Height:=lHght, Width:=lWdth)
    With ShpArrow
      .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
      .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      With .Fill
        .Visible = msoTrue
        .Solid
        .ForeColor.RGB = RGB(255, 255, 0)
        .Transparency = 0#
      End With
      With .Line
        .Weight = 0.75
        .DashStyle = msoLineSolid
        .Style = msoLineSingle
        .Transparency = 0#
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .BackColor.RGB = RGB(255, 255, 255)
      End With
      .Rotation = 0#
      .LockAnchor = False
      .WrapFormat.Type = wdWrapFront
    End With
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by charcaltay Saturday, September 8, 2012 4:20 PM
    Saturday, September 8, 2012 9:56 AM

All replies

  • Not without seeing your existing macro for inserting the arrows ...

    As an alternative, have you considered creating a custom Quick Part with the desired attributes?


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Saturday, September 8, 2012 2:31 AM
  • Paul, Thanks for the response

    I do not have an existing macro for inserting the arrow. Using Word 2010; I click insert, shape, arrow and then resize it to fit inside the picture. My macro currently resizes the pic and adds a solid border to them. I was hoping to gain insight into the possiblity of adding these steps to my current macro, making it all a one click step. Editing my pictures takes roughly 30 minutes per report and I am looking for ways to streamline the process. That being said......what is a custom Quick Part? I am obviously a very novice user....

    Thanks again for responding!

    Saturday, September 8, 2012 4:05 AM
  • For Custom Quick Parts, see: http://office.microsoft.com/en-us/word-help/quick-parts-HA010370568.aspx

    Apart from that, you could, of course, record a macro while inserting & formatting an arrow symbol. You could then replay the macro any time you need to insert an new one.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Saturday, September 8, 2012 4:09 AM
  • Thanks Paul

    I am currently making my first attempt at writing a macro. 1hr=1line of code :) This could take some time but if I make some more progress or get stuck I'll post it and maybe get some feedback.

    I tried the quick parts and that did not really seem to make my process any more effecient but I thank you for suggesting it

    Saturday, September 8, 2012 5:08 AM
  • Using the macro recorder should very quickly give you a bunch of code to work with. I used it to record the insertion, colouring and positioning of an arrow in a fwe seconds. It generated a bunch of code that I've trimmed and refined to:

    Sub AddArrow()
    Dim ShpArrow As Shape
    Set ShpArrow = ActiveDocument.Shapes.AddShape(msoShapeRightArrow, _
      Top:=CentimetersToPoints(5), Left:=CentimetersToPoints(5), _
      Height:=CentimetersToPoints(1.25), Width:=CentimetersToPoints(2.5))
    With ShpArrow
      With .Fill
        .Visible = msoTrue
        .Solid
        .ForeColor.RGB = RGB(255, 255, 0)
        .Transparency = 0#
      End With
      With .Line
        .Weight = 0.75
        .DashStyle = msoLineSolid
        .Style = msoLineSingle
        .Transparency = 0#
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .BackColor.RGB = RGB(255, 255, 255)
      End With
      .Rotation = 0#
      .LockAnchor = False
      .WrapFormat.Type = wdWrapSquare
    End With
    End Sub

    This inserts a 1.25*2.5cm yellow arrow with a red border 5cm below and to the right of the top corner.


    Cheers
    Paul Edstein
    [MS MVP - Word]

    Saturday, September 8, 2012 6:35 AM
  • With your macro, I now have all I need to make this work... Thank you so much.

    Any suggestion on how to combine the arrow macro into the following macro, so that the arrow will stay within the boundaries of the picture once it is resized?

    Sub FormatPicture()

    Selection.InlineShapes(1).Borders.OutsideLineStyle = wdLineStyleSingle
    Selection.InlineShapes(1).Borders.OutsideLineWidth = wdLineWidth100pt
    Selection.InlineShapes(1).Borders.OutsideColor = wdColorAutomatic

     
        Dim shp As Word.shape
        Dim ishp As Word.InlineShape
     
       
        If Word.Selection.Type <> wdSelectionInlineShape And _
            Word.Selection.Type <> wdSelectionShape Then
            Exit Sub
        End If
       
        If Word.Selection.Type = wdSelectionInlineShape Then
            Set ishp = Word.Selection.Range.InlineShapes(1)
            ishp.LockAspectRatio = False
            ishp.Height = InchesToPoints(2)
            ishp.Width = InchesToPoints(2.67)
        Else
        If Word.Selection.Type = wdSelectionShape Then
                Set shp = Word.Selection.ShapeRange(1)
                shp.LockAspectRatio = False
                shp.Height = InchesToPoints(2)
                shp.Width = InchesToPoints(2.67)
           
        End If
        End If
                 
    End Sub

    Saturday, September 8, 2012 7:02 AM
  • Perhaps something along the lines of:

    Sub FormatPicture()
    Dim shp As Word.Shape
    Dim ishp As Word.InlineShape
    Dim lWdth As Single, lHght As Single, lTop As Single, lLeft As Single
    Dim vAlignV, vAlignH, lArrW As Single, lArrH As Single
    lWdth = InchesToPoints(2.67): lHght = InchesToPoints(2)
    lArrW = InchesToPoints(1): lArrH = lArrW / 2
    With Word.Selection
      If .Type = wdSelectionInlineShape Then
        With .InlineShapes(1)
          .LockAspectRatio = False
          lLeft = .Range.Information(wdHorizontalPositionRelativeToPage)
          lTop = .Range.Information(wdVerticalPositionRelativeToPage)
          .Height = lHght
          .Width = lWdth
        End With
        Call AddArrow(lArrW, lArrW / 2, lTop + lHght / 8, lLeft)
      ElseIf .Type = wdSelectionShape Then
        With .ShapeRange
          .LockAspectRatio = False
          vAlignH = .RelativeHorizontalPosition
          vAlignV = .RelativeVerticalPosition
          .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
          .RelativeVerticalPosition = wdRelativeVerticalPositionPage
          .RelativeHorizontalPosition = vAlignH
          .RelativeVerticalPosition = vAlignV
          lLeft = .Left
          lTop = .Top
          .Height = lHght
          .Width = lWdth
        End With
        Call AddArrow(lArrW, lArrH, lTop + lHght / 3, lLeft)
      End If
    End With
    End Sub

    Sub AddArrow(lWdth As Single, lHght As Single, lTop As Single, lLeft As Single)
    Dim ShpArrow As Shape
    Set ShpArrow = ActiveDocument.Shapes.AddShape(msoShapeRightArrow, _
      Top:=lTop, Left:=lLeft, Height:=lHght, Width:=lWdth)
    With ShpArrow
      .RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
      .RelativeVerticalPosition = wdRelativeVerticalPositionPage
      With .Fill
        .Visible = msoTrue
        .Solid
        .ForeColor.RGB = RGB(255, 255, 0)
        .Transparency = 0#
      End With
      With .Line
        .Weight = 0.75
        .DashStyle = msoLineSolid
        .Style = msoLineSingle
        .Transparency = 0#
        .Visible = msoTrue
        .ForeColor.RGB = RGB(255, 0, 0)
        .BackColor.RGB = RGB(255, 255, 255)
      End With
      .Rotation = 0#
      .LockAnchor = False
      .WrapFormat.Type = wdWrapFront
    End With
    End Sub


    Cheers
    Paul Edstein
    [MS MVP - Word]

    • Marked as answer by charcaltay Saturday, September 8, 2012 4:20 PM
    Saturday, September 8, 2012 9:56 AM
  • That's it! I ran the macro and it executed every task I use to edit my pics. I cannot thank you enough for your assistance. Your help will save me 5-10 hours of week time each week...

    Thanks again!

    Saturday, September 8, 2012 4:20 PM