How to save a wordart as METAFILE?

[cscorp]

The code below save a wordart as a bitmap. I need to modify it to save
the wordart as a metafile. Thanks in advance

Option Explicit
Private Declare Function IsClipboardFormatAvailable Lib "user32"
(ByValwFormat 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

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

Private Function PasteBmp() As IPicture
Dim hCopy As Long
OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(2), 0, 0, 0, &H4)
CloseClipboard
If hCopy Then Set PasteBmp = CreateBmp(hCopy, 0, 2)
End Function

Private Function CreateBmp(ByVal hPic As Long, ByVal hPal As Long,
ByVal lPicType) As IPicture
Dim i As Long, PicInfo As uPicDesc, OlePicStore As GUID, IPic As
IPicture
' Fill in magic IPicture GUID
{7BF80980-BF32-101A-8BBB-00AA00300CAB}

With OlePicStore
..Data1 = &H7BF80980: .Data2 = &HBF32: .Data3 = &H101A

For i = 1 To 8
..Data4(i - 1) = Choose(i, &H8B, &HBB, &H0, &HAA, &H0, &H30,
&HC, &HAB)
Next i

End With

With PicInfo
..Size = Len(PicInfo)
..Type = 1
..hPic = hPic
..hPal = hPal
End With

If OleCreatePictureIndirect(PicInfo, OlePicStore, True, IPic) Then
Exit Function

Set CreateBmp = IPic
End Function

Sub SaveShapeAsBmp()
If ThisWorkbook.Sheets(1).Shapes.Count = 0 Then Exit Sub

On Error GoTo SaveBmp_Error

Dim Img As Shape, oPic As IPictureDisp, BmpFile As String

For Each Img In ThisWorkbook.Sheets(1).Shapes
Img.CopyPicture xlScreen, xlBitmap
BmpFile = ThisWorkbook.Path & "\" & Img.Name & ".bmp"
Set oPic = PasteBmp
SavePicture oPic, BmpFile
Next Img
Exit Sub

SaveBmp_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

 

[Michel Pierron]

Hi cscorp,
You can test:

Option Explicit
Private Declare Function _
CloseClipboard& Lib "user32" ()
Private Declare Function _
OpenClipboard& Lib "user32" (ByVal hwnd&)
Private Declare Function _
EmptyClipboard& Lib "user32" ()
Private Declare Function _
GetClipboardData& Lib "user32" (ByVal wFormat&)
Private Declare Function CopyEnhMetaFileA& _
Lib "gdi32" (ByVal hemfSrc&, ByVal lpszFile$)
Private Declare Function _
DeleteEnhMetaFile& Lib "gdi32.dll" (ByVal hemf&)

Sub SaveShapeAsMetafile()
If ThisWorkbook.Sheets(1).Shapes.Count = 0 Then Exit Sub
On Error GoTo SaveWmf_Error
Dim Img As Shape, hCopy&, fName$
For Each Img In ThisWorkbook.Sheets(1).Shapes
Img.Copy: OpenClipboard 0&
hCopy = GetClipboardData(14)
If hCopy Then
fName = ThisWorkbook.Path & "\" & Img.Name & ".wmf"
DeleteEnhMetaFile CopyEnhMetaFileA(hCopy, fName)
EmptyClipboard
End If
CloseClipboard
Next Img
Exit Sub
SaveWmf_Error:
MsgBox "Error " & Err.Number & vbLf & Err.Description, 48
End Sub

Regards,
MP

 

[cscorp]

Michael

Thank you very much!

Best Regards.

Juan Carlos