Sub AOptimize()

Dim answer As Integer
 
answer = MsgBox("Optimize document?", vbQuestion + vbYesNo + vbDefaultButton2, "Optimize (C) L. Zwanikken")
    
If answer = vbYes Then
    Call CompressPics
    Call ResizePics
    Call Done
Else
  MsgBox "Aborted"
End If
End Sub
Sub ResizePics()
     Dim shp As Shape
     Dim ish As InlineShape
     For Each shp In ActiveDocument.Shapes
         Select Case shp.Type
             Case msoPicture, msoLinkedPicture
                 shp.Line.Style = msoLineSingle
                 With shp.Line
                    .Style = msoLineSingle
                    .Weight = 1
                    .ForeColor = wdColorBlack
                 End With
         End Select
     Next shp
     For Each ish In ActiveDocument.InlineShapes
         Select Case ish.Type
             Case wdInlineShapePicture, wdInlineShapeLinkedPicture
                 With ish.Line
                    .Style = msoLineSingle
                    .Weight = 1
                    .ForeColor = wdColorBlack
                 End With
         End Select
     Next ish

    Dim i As Long
    With ActiveDocument
    For i = 1 To .InlineShapes.Count
        With .InlineShapes(i)
            .Height = 161
            .Width = 300
            .LockAspectRatio = True
        End With
    Next i
End With
End Sub
Sub CompressPics()
    With Application.CommandBars.FindControl(ID:=6382)
        SendKeys "%A%W{Enter}"
        .Execute
    End With
End Sub
Sub CreateTextBox()
    Dim Box As Shape
    Set Box = ActiveDocument.Shapes.AddTextbox( _
        Orientation:=msoTextOrientationHorizontal, _
        Left:=425, Top:=150, Width:=100, Height:=50)

        Box.TextFrame.TextRange.Text = "Beschrijving hier"
End Sub
Sub Done()
MsgBox ("Optimizing document done!")
End Sub