ActiveSheet.Paste
 
    Selection.ShapeRange.LockAspectRatio = msoFalse
    Selection.ShapeRange.IncrementLeft 0.00007874015748
    Selection.ShapeRange.ScaleWidth 0.5, msoFalse, msoScaleFromTopLeft
    Selection.ShapeRange.PictureFormat.Crop.PictureWidth = 2879
    Selection.ShapeRange.PictureFormat.Crop.PictureHeight = 809
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetX = 719
    Selection.ShapeRange.PictureFormat.Crop.PictureOffsetY = 0
 
    Selection.Copy
 
Dim Docname
Docname = "C:\filepath\BlankWord.docx"
 
Dim WordDoc As Object
Dim WordApp As Object
Set WordApp = CreateObject("word.Application")
 
If IsFileOpen("C:\filepath\BlankWord.docx") Then
    WordApp.Visible = True
    Set WordDoc = GetObject(Docname)   """ this seems to be where I run into trouble
Else
    WordApp.Documents.Open (Docname)
End If
 
WordApp.Visible = True
WordApp.Selection.Paste

Function IsFileOpen(filename As String)
    Dim filenum As Integer, errnum As Integer
    On Error Resume Next   ' Turn error checking off.
    filenum = FreeFile()   ' Get a free file number.
    ' Attempt to open the file and lock it.
    Open filename For Input Lock Read As #filenum
    Close filenum          ' Close the file.
    errnum = Err           ' Save the error number that occurred.
    On Error GoTo 0        ' Turn error checking back on.
    ' Check to see which error occurred.
    Select Case errnum
        ' No error occurred.
        ' File is NOT already open by another user.
        Case 0
         IsFileOpen = False
        ' Error number for "Permission Denied."
        ' File is already opened by another user.
        Case 70
            IsFileOpen = True
        ' Another error occurred.
        Case Else
            Error errnum
    End Select

Sub BackupCropperResizer()
'
' BackupCropperResizer Macro
'
'
  Dim sngWidth, sngCrop As Single
 sngCrop = 3.075
 
 
 Selection.WholeStory
 
With Selection.InlineShapes(1)
 sngWidth = .Width
 With .PictureFormat
 .CropRight = sngWidth * sngCrop
 End With
 End With
 
 On Error Resume Next
 With Selection.InlineShapes(2)
 sngWidth = .Width
 With .PictureFormat
 .CropRight = sngWidth * sngCrop
 End With
 End With
 
On Error Resume Next
With Selection.InlineShapes(3)
 sngWidth = .Width
 With .PictureFormat
 .CropRight = sngWidth * sngCrop
 End With
 End With
 
 
 Dim i As Long
With ActiveDocument
 For i = 1 To .InlineShapes.Count
 With .InlineShapes(i)
 .ScaleHeight = 33
 End With
 Next i
End With
 
End Sub