Сохранение картинки из буфера обмена в файл.

[viter.alex]

Есть функция, которая сохраняет картинку, скопированую из Word, в файл. Код этой функции такой:

Option Explicit
'Сохранения рисунка из буфера обмена в файл Clip2File()
'### Paste into a standard module - call Clip2File ###
'##################################################

' Checks the clipboard for a bitmap
' If found, creates a standard Picture object from the
' clipboard contetnts and saves it to a file

' The code requires a reference to the "OLE Automation" type library

' The code in this module has been derived primarily from _
' the PatsePicture sample on Stephen Bullen's Excel Page _
' - http://www.bmsltd.ie/Excel/Default.htm

'Windows API Function Declarations
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

'The API format types we need
Const CF_BITMAP = 2
Const IMAGE_BITMAP = 0
Const LR_COPYRETURNORG = &H4
'Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
  Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(0 To 7) As Byte
End Type

'Declare a UDT to store the bitmap information
Private Type uPicDesc
  Size As Long: Type As Long: hPic As Long: hPal As Long
End Type
Public Function Clip2File(Optional Filename As String, Optional Path = "")
  Dim sFileName As String, sPath As String
  Dim strOutputPath As String, oPic As IPictureDisp
  'Путь к папке для сохранения файла
  'Если путь пустой, то копируем в «TEMP». Если нет, то в указанyю папку
  sPath = IIf(Path = "", Environ("TEMP"), Path)
  'Если имя файла не указано, то генерируем случайное имя
  If Filename = "" Then
    Dim FSO As Object
    Set FSO = CreateObject("Scripting.FileSystemObject")
    sFileName = FSO.GetTempName(): sFileName = Mid(sFileName, 1, InStrRev(sFileName, ".") - 1)
  Else: sFileName = Filename: End If
  'Get the filename to save the bitmap to
  strOutputPath = sPath & "\" & sFileName & ".bmp"
  'Retrieve the picture from the clipboard...
  Set oPic = GetClipPicture()
  '... and save it to the file
  If Not oPic Is Nothing Then
    SavePicture oPic, strOutputPath
    Clip2File = strOutputPath
  Else
    Clip2File = ""
    MsgBox "Unable to retrieve bitmap from clipboard"
  End If
End Function
Function GetClipPicture() As IPicture
  Dim h As Long, hPicAvail As Long, hPtr As Long, _
  hPal As Long, hCopy As Long
 'Check if the clipboard contains a bitmap
  'Опpеделяет, имеются ли в буфеpе выpезанного изобpажения данные в указанном фоpмате
  hPicAvail = IsClipboardFormatAvailable(CF_BITMAP)
  If hPicAvail <> 0 Then
    'Get access to the clipboard
    h = OpenClipboard(0&)
    If h > 0 Then
      'Get a handle to the image data
      hPtr = GetClipboardData(CF_BITMAP)
      hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
      'Release the clipboard to other programs
      h = CloseClipboard
      'If we got a handle to the image, convert it into _
      'a Picture object and return it
      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
   ' IPicture requires a reference to "OLE Automation"
  Dim r As Long, uPicInfo As uPicDesc, IID_IDispatch As GUID, _
  IPic As IPicture
  'OLE Picture types
  Const PICTYPE_BITMAP = 1
  ' Create the Interface GUID (for the IPicture interface)
  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
 ' Fill uPicInfo with necessary parts.
  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
  ' Create the Picture object.
  r = OleCreatePictureIndirect(uPicInfo, IID_IDispatch, True, IPic)
  
  ' Return the new Picture object.
  Set CreatePicture = IPic
End Function

[viter.alex]

Но она работает, только с картинкой. Если применить команду Selection.CopyAsPicture, то выдается сообщение, что невозможно получить изображение из буфера. Проблема в функции, выделеной красным цветом. Она работает только с типом CF_BITMAP. Как научить работать с тем типом, который копирует Word?