GDIplusCODE


'http://www.moug.net/faq/viewtopic.php?t=47986
'shiraさん→kanabunさん

Private Type FLTIMAGE
    StructSize As Integer
    Type As Byte
    Reserved1(0 To 8) As Byte
    hImage As Long
    Reserved3(0 To 19) As Byte
End Type
Private Type FLTFILE
    Reserved1 As Integer
    Ext As String * 4
    Reserved2 As Integer
    Path As String * 260
    Reserved3 As Currency
End Type

'ここで出力形式を選択する
#Const FLT_MODE = -1

'2013/7/28 追記
'このコードはWindows7Home(64bit)環境のXL2010では動きませんでした。
'原因はエクセル側で無く、Officeのグラフィックフィルターの場所でした。
'Windows7Home(64bit)では、JPEGフィルターの例で、
'C:\Program Files (x86)\Common Files\microsoft shared\GRPHFLT\JPEGIM32.FLT
'にありました。

#If FLT_MODE = -1 Then  'PNG
    Private Declare Function GetFilterInfo Lib _
      "C:\Program Files\Common Files\Microsoft Shared\Grphflt\PNG32.FLT" _
       (ByVal Ver As Integer, ByVal Reserved As Long, _
        phMem As Long, ByVal flags As Long) As Long
    Private Declare Function ExportGr Lib "PNG32.FLT" _
       (ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
    Private Const SaveExt As String = "PNG保存,*.png"
#ElseIf FLT_MODE = 1 Then 'JPEG
    Private Declare Function GetFilterInfo Lib _
      "C:\Program Files\Common Files\Microsoft Shared\Grphflt\JPEGIM32.FLT" _
       (ByVal Ver As Integer, ByVal Reserved As Long, _
        phMem As Long, ByVal flags As Long) As Long
    Private Declare Function ExportGr Lib "JPEGIM32.FLT" _
       (ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
    Private Const SaveExt As String = "Jpeg保存,*.Jpg"
#ElseIf FLT_MODE = 2 Then 'TIFF
 Private Declare Function GetFilterInfo Lib _
  "C:\Program Files\Common Files\Microsoft Shared\Grphflt\TIFFIM32.FLT" _
        (ByVal Ver As Integer, ByVal Reserved As Long, _
         phMem As Long, ByVal flags As Long) As Long
  Private Declare Function ExportGr Lib "TIFFIM32.FLT" _
      (ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
  Private Const SaveExt As String = "TIFF保存,*.Tif"
#Else '                 GIF
    Private Declare Function GetFilterInfo Lib _
      "C:\Program Files\Common Files\Microsoft Shared\Grphflt\GIFIMP32.FLT" _
       (ByVal Ver As Integer, ByVal Reserved As Long, _
        phMem As Long, ByVal flags As Long) As Long
    Private Declare Function ExportGr Lib "GIFIMP32.FLT" _
       (ff As FLTFILE, fi As FLTIMAGE, ByVal hMem As Long) As Long
    Private Const SaveExt As String = "GIF保存,*.Gif"
#End If

Private Declare Function OpenClipboard Lib "user32" _
        (ByVal hWndNewOwner As Long) As Long
Private Declare Function GetClipboardData Lib "user32" _
        (ByVal uFormat As Long) As Long
Private Declare Function CloseClipboard Lib "user32" () 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
Private Declare Function GlobalFree Lib "kernel32" _
       (ByVal hMem As Long) As Long

Function SaveCBPictureAs(ByVal SavePath As String) As Boolean
' クリップボードにコピーされたEMFイメージを _
              定数 FLT_MODE で指定された形式で保存
  Dim fi   As FLTIMAGE
  Dim ff   As FLTFILE
  Dim hemf As Long
  Dim hMem As Long

  If OpenClipboard(0) Then
      hemf = CopyEnhMetaFile( _
              GetClipboardData(CF_ENHMETAFILE), vbNullString)
      CloseClipboard
  End If
  If hemf = 0 Then Exit Function
  ' パラメータ設定
  ff.Path = SavePath & vbNullChar
  With fi
      .StructSize = LenB(fi)
      .Type = 1
      .hImage = hemf
  End With
  ' フィルタ呼び出し
  If GetFilterInfo(3, 0, hMem, &H10000) And &H10 Then
      If ExportGr(ff, fi, hMem) = 0 Then
          SaveCBPictureAs = True
      End If
  End If
  If hMem Then GlobalFree hMem
  DeleteEnhMetaFile hemf
End Function
 
Sub 動作テスト()
    Dim myPath
    myPath = "c:\testMetatoBitmap.png"
    
    Call Selection.CopyPicture(xlPrinter, xlPicture)
		’または、shift+編集、図のコピーで、用紙に合わせるを選択
    If SaveCBPictureAs(myPath) Then
        MsgBox "保存しました", vbInformation, Dir(myPath)
    Else
        MsgBox "失敗しました"
    End If
End Sub
WS上の画像の上にshapeを書き加えて、画像ファイルとして保存（その２）
