Сложности с программным сохранением картинок на диск

Option Explicit
Private Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle _
As Long, IPic As IPicture) As Long
Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, _
ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, _
ByVal un2 As Long) As Long
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
Private Type GUID
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
Private Type uPicDesc
  Size As Long
  Type As Long
  hPic As Long
  hPal As Long
End Type
 
Sub Black_Romeo()
    Dim s
    For Each s In ActiveDocument.InlineShapes
        s.Select
        Selection.Copy
        Clip2File
    Next
End Sub
 
Private Function Clip2File()
  Dim strOutputPath As String, oPic As IPictureDisp
  Randomize
  strOutputPath = ThisDocument.Path & "\" & CStr(Int(Rnd * 10000)) & ".bmp"
  Set oPic = GetClipPicture()
  If Not oPic Is Nothing Then
    SavePicture oPic, strOutputPath
    Clip2File = strOutputPath
    MsgBox "Saved as " & strOutputPath
  Else
    Clip2File = ""
    MsgBox "Unable to retrieve bitmap from clipboard"
  End If
End Function
 
Private Function GetClipPicture() As IPicture
  Dim h As Long, hPicAvail As Long, hPtr As Long, _
  hPal As Long, hCopy As Long
  hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
  
  If hPicAvail <> 0 Then
    h = OpenClipboard(0&)
    If h > 0 Then
      hPtr = GetClipboardData(CF_BITMAP)
      hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
      h = CloseClipboard
      If hPtr <> 0 Then Set GetClipPicture = CreatePicture(hCopy, _
        0, CF_BITMAP)
    End If
  End If
End Function
 
Private Function CreatePicture(ByVal hPic As Long, ByVal hPal As Long, ByVal lPicType) As IPicture
  Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, IPic As IPicture
  Const PICTYPE_BITMAP = 1
  With IID_IDispatch
    .Data1 = &H7BF80980
    .Data2 = &HBF32
    .Data3 = &H101A
    .Data4(0) = &H8B
    .Data4(1) = &HBB
    .Data4(2) = &H0
    .Data4(3) = &HAA
    .Data4(4) = &H0
    .Data4(5) = &H30
    .Data4(6) = &HC
    .Data4(7) = &HAB
  End With
  With uPicInfo
    .Size = Len(uPicInfo) ' Length of structure.
    .Type = PICTYPE_BITMAP ' Type of Picture
    .hPic = hPic ' Handle to image.
    .hPal = 0 ' Handle to palette (if bitmap).
  End With
  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
  Set CreatePicture = IPic
End Function

Private Sub Command1_Click()
DocFile = "H:\Down\Файл с Картинкой.docx" 'путь к документу
ZipFile = DocFile & ".zip"
ExtractTo = "C:\temp\doc"  '  папка куда будет извлекатся архив
Name DocFile As ZipFile     ' делаем из дока зип
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists(ExtractTo) Then
fso.CreateFolder (ExtractTo)
End If
Set objShell = CreateObject("Shell.Application")
Set FilesInZip = objShell.NameSpace(ZipFile).items
objShell.NameSpace(ExtractTo).CopyHere (FilesInZip)
Set fso = Nothing
Set objShell = Nothing
 
 
Name ZipFile As DocFile ' переименовываем назад
                                    'Все картинки тут: C:\temp\doc\word\media\
                                    'Можно переместить их куда угодно, а папку  C:\temp\doc удалить или очистить
End Sub