VBA Word Shape Shortcut.txt

Sub ConvertOLEObjectsToPicture()
  Dim Item As InlineShape
  For Each Item In ActiveDocument.InlineShapes
    Select Case Item.Type
      Case wdInlineShapeEmbeddedOLEObject, wdInlineShapeLinkedOLEObject
        Item.Select
        With Selection
          .CopyAsPicture
          .Delete
          .PasteSpecial DataType:=wdPasteMetafilePicture
          '.ShapeRange.WrapFormat.Type = wdWrapTopBottom
        End With
    End Select
  Next
End Sub
Sub RemoveTextBoxtotext()
    Dim shp As Shape
    Dim oRngAnchor As Range
    Dim sString As String

    For Each shp In ActiveDocument.Shapes
        If shp.Type = msoTextBox Then
            ' copy text to string, without last paragraph mark
            sString = Left(shp.TextFrame.TextRange.Text, _
              shp.TextFrame.TextRange.Characters.Count - 1)
            If Len(sString) > 0 Then
                ' set the range to insert the text
                Set oRngAnchor = shp.Anchor.Paragraphs(1).Range
                ' insert the textbox text before the range object
                oRngAnchor.InsertBefore _
                  "Textbox start << " & sString & " >> Textbox end"
            End If
            shp.Delete
        End If
    Next shp
End Sub
Sub DontMoveWithTextImagesBehind()
    Dim shp As Shape
    For Each shp In ActiveDocument.Shapes
        shp.RelativeVerticalPosition = wdRelativeVerticalPositionPage
        shp.WrapFormat.Type = wdWrapBehind
    Next shp
End Sub
Sub Macro1()
'
' Macro1 Macro
'
'
End Sub
Sub Macro2()
'
' Macro2 Macro
'
'
    Selection.WholeStory
End Sub
Sub down()
'
' down Macro
'
'
    Selection.MoveDown Unit:=wdLine, Count:=1
End Sub
Sub Wait(ByVal Seconds As Single)
    Dim CurrentTimer As Variant
    CurrentTimer = Timer
    Do While Timer < CurrentTimer + Seconds
    Loop
End Sub
Sub selirrshape()
SendKeys "%{4}"
Application.OnTime Now + TimeValue("00:00:01"), ?NameOfMacroToRun?
SendKeys "{Down}"
Application.OnTime Now + TimeValue("00:00:01"), ?NameOfMacroToRun?
SendKeys "{Enter}"
End Sub
Sub Allimagesbehind()
Dim i As Long, rng As Range
With ActiveDocument
    For i = .InlineShapes.Count To 1 Step -1
        With .InlineShapes(i)
            Set rng = .Range
            .ConvertToShape
            rng.ShapeRange(1).WrapFormat.Type = wdWrapBehind
            pic.WrapFormat.Type = wdWrapNone
        End With
    Next i
End With
End Sub
Sub Imagesbehindtest()
    Dim ILS As InlineShape
    Dim shp As Shape
    Set ILS = ActiveDocument.InlineShapes(1)
    Set shp = ILS.ConvertToShape
    With shp
        .WrapFormat.Type = wdWrapBehind
    End With
End Sub
Sub Imagesbehindtrya()

End Sub
Sub Imagesbehindtesta()
Dim i As Long
With ActiveDocument
  For i = .InlineShapes.Count To 1 Step -1
    With .InlineShapes(i)
      If .Type = wdInlineShapePicture Then
        .ConvertToShape
      End If
    End With
  Next
  For i = 1 To .Shapes.Count
    With .Shapes(i)
      If .Type = msoPicture Then
        .WrapFormat.Type = wdWrapBehind
        .LockAspectRatio = msoTrue
        .Width = InchesToPoints(1)
      End If
    End With
  Next
End With
End Sub
Sub PictureFormat()
    If Selection.ShapeRange.Count = 0 Then
        If Selection.InlineShapes.Count = 1 Then
            Selection.InlineShapes(1).ConvertToShape
        Else
            MsgBox "Select a picture first.", , "Oops!"
            Exit Sub
        End If
    End If
    
    With Selection.ShapeRange(1)
        .Top = CentimetersToPoints(0.5)
        .RelativeVerticalPosition = _
            wdRelativeVerticalPositionParagraph
        .Left = CentimetersToPoints(3)
        .RelativeHorizontalPosition = _
            wdRelativeHorizontalPositionColumn
        With .WrapFormat
            .Type = wdWrapBehind
            .DistanceTop = CentimetersToPoints(0.2)
            .DistanceBottom = CentimetersToPoints(0.2)
        End With
    End With
End Sub
Sub Macro6()
'
' Macro6 Macro
'
'
End Sub
Sub Allimagesbehindtestc()
    Dim ILS As InlineShape
    Dim shp As Shape
    Set ILS = ActiveDocument.InlineShapes(1)
    Set shp = ILS.ConvertToShape
    With shp
        .WrapFormat.Type = wdWrapBehind
        .RelativeVerticalPosition = wdRelativeVerticalPositionMargin
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionMargin
        .Left = InchesToPoints(1)
        .Top = InchesToPoints(1)
    End With
End Sub
Sub PixWrapBehind()
    Dim ILS As InlineShape
    Dim shp As Shape
    Dim p As Paragraph
    Dim moveAnchor As Boolean
    
    For Each ILS In ActiveDocument.InlineShapes
        Set p = ILS.Range.Paragraphs(1)
        ' Determine whether ILS is in an otherwise empty paragraph
        ' or is followed by something else. It it's alone, we have to
        ' move the anchor to the next paragraph and delete the
        ' empty paragraph mark.
        moveAnchor = (Len(p.Range.Text) < 3)
        
        Set shp = ILS.ConvertToShape
        With shp
            .WrapFormat.Type = wdWrapBehind
            .Left = wdShapeLeft
            If moveAnchor Then
                shp.Select
                Selection.Cut
                Selection.MoveDown wdParagraph, 1
                Selection.Paste
                p.Range.Delete
            End If
        End With
    Next
End Sub