GDIplusCODE


Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
Private Type PICTDESC
cbSizeofstruct As Long
picType As Long
hEmf As Long
Padding(0 To 1) As Long
End Type
Const PICTYPE_ENHMETAFILE = 4

Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PICTDESC, riid As GUID, ByVal fOwn As Long, lplpvObj As Object) As Long
Private Declare Function OpenClipboard Lib "user32" (ByVal hWndNewOwner As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal uFormat As Long) As Long
Const CF_ENHMETAFILE = 14
Private Declare Function CopyEnhMetaFile Lib "gdi32" Alias "CopyEnhMetaFileA" (ByVal hemfSrc As Long, ByVal lpszFile As String) As Long
Private Declare Function DeleteEnhMetaFile Lib "gdi32" (ByVal hEmf As Long) As Long

Sub selectionToEMFfile()
If TypeName(Selection) <> "Range" Then Exit Sub
Selection.Copy
SavePicture CreatePictureFromCB(), "c:\saveEmfTest.emf"
End Sub

Private Function CreatePictureFromCB() As Object
	'CreatePictureFromCB(by Shiraさん)はweb検索してください...と書きましたが
	'Web検索しても、リンク切れになったりしているので、載せておきます

    Dim IID_Idispatch As GUID
    Dim pd As PICTDESC
    Dim objResult As Object
    Dim hemf As Long

    If OpenClipboard(0) Then
        hemf = GetClipboardData(CF_ENHMETAFILE)
        ' ハンドルを複製してから使用する
        hemf = CopyEnhMetaFile(hemf, vbNullString)
        CloseClipboard
    End If
    If hemf = 0 Then Exit Function  ' 失敗
    With IID_Idispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With pd
        .cbSizeofstruct = Len(pd)
        .picType = PICTYPE_ENHMETAFILE
        .hemf = hemf
    End With
    If OleCreatePictureIndirect(pd, IID_Idispatch, _
                                1, objResult) >= 0 Then
        ' 成功時
        Set CreatePictureFromCB = objResult
    Else
        ' 失敗時
        DeleteEnhMetaFile hemf
    End If
End Function
エクセルで選択範囲をemf形式で保存（その１）
