GDIplusCODE


Option Explicit


'====== 構造体 ======

'Globally Unique Identifier構造体
Private Type uuid
  Data1 As Long
  Data2 As Integer
  Data3 As Integer
  Data4(0 To 7) As Byte
End Type
'Picture Descriptor構造体 MSDN(Eng)参照
Private Type PICTDESC
  cbSizeofstruct As Long
  picType As Long
  hBitmap As Long
  hpal As Long
  unused_wmf_yExt As Long
End Type

Private Type RECT
  Left    As Long
  Top     As Long
  Right   As Long
  Bottom  As Long
End Type

Private Type METAFILEPICT
  mm As Long
  xExt As Long
  yExt As Long
  hmf As Long
End Type

Private Type RECTL
  Left As Long
  Top As Long
  Right As Long
  Bottom As Long
End Type

Private Type SIZEL
  cx As Long
  cy As Long
End Type

Type BITMAPINFOHEADER
  biSize As Long              'ヘッダーのサイズ
  biWidth As Long             '幅(ピクセル単位)
  biHeight As Long            '高さ(ピクセル単位)
  biPlanes As Integer         '常に１
  biBitCount As Integer       '1ピクセルあたりのカラービット数
  biCompression As Long       '圧縮方法
  biSizeImage As Long         'ピクセルデータの全バイト数
  biXPelsPerMeter As Long     '0または水平解像度
  biYPelsPerMeter As Long     '0または垂直解像度
  biClrUsed As Long           '通常は0
  biClrImportant As Long      '通常は0
End Type

Type RGBQUAD
  rgbBlue As Byte             '青の濃さ
  rgbGreen As Byte            '緑の濃さ
  rgbRed As Byte              '赤の濃さ
  rgbReserved As Byte         '未使用(常に0)
End Type

Type BITMAPINFO
  bmiHeader As BITMAPINFOHEADER
  bmiColors As RGBQUAD
End Type

Private Type ENHMETAHEADER
  iType As Long
  nSize As Long
  rclBounds As RECTL
  rclFrame As RECTL '0.01mm単位
  dSignature As Long
  nVersion As Long
  nBytes As Long
  nRecords As Long
  nHandles As Integer
  sReserved As Integer
  nDescription As Long
  offDescription As Long
  nPalEntries As Long
  szlDevice As SIZEL
  szlMillimeters As SIZEL
End Type

'GDI+
'Private Type uuid
' Data1 As Long
' Data2 As Integer
' Data3 As Integer
' Data4(7) As Byte
' End Type
Private Type GdiplusStartupInput
  GdiplusVersion As Long
  DebugEventCallback As Long
  SuppressBackgroundThread As Long
  SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
  uuid As uuid
  NumberOfValues As Long
  Type As Long
  Value As Long
End Type

Private Type EncoderParameters
  Count As Long
  Parameter(15) As EncoderParameter
End Type

'===== GDI+ 関係
Public Enum myPixelFormat
  PixelFormatUndefined = &H0
  PixelFormat1bppIndexed = &H30101
  PixelFormat4bppIndexed = &H30402
  PixelFormat8bppIndexed = &H30803
  PixelFormat16bppGrayScale = &H101004
  PixelFormat16bppRGB555 = &H21005
  PixelFormat16bppRGB565 = &H21006
  PixelFormat16bppARGB1555 = &H61007
  PixelFormat24bppRGB = &H21808
  PixelFormat32bppRGB = &H22009
  PixelFormat32bppARGB = &H26200A
  PixelFormat32bppPARGB = &HE200B
  PixelFormat48bppRGB = &H10300C
  PixelFormat64bppARGB = &H34400D
  PixelFormat64bppPARGB = &H1A400E
End Enum

Private Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Const ENCODER_BMP    As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_JPG    As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_GIF    As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_TIF    As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const ENCODER_PNG    As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"

Private Declare Function GdiplusStartup Lib "gdiplus.dll" (ByRef token As Long, ByRef inputBuf As GdiplusStartupInput, ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus.dll" (ByVal token As Long)
Private Declare Function GdipBitmapGetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, color As Long) As Long
Private Declare Function GdipBitmapSetPixel Lib "gdiplus" (ByVal bitmap As Long, ByVal x As Long, ByVal y As Long, ByVal color As Long) As Long
Private Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Private Declare Function GdipCreateBitmapFromFile Lib "gdiplus" (fileName As Any, bitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus.dll" (ByVal nWidth As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, nBitmap As Long) As Long
Private Declare Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As Long, ByVal hpal As Long, ByRef bitmap As Long) As Long
Private Declare Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As Long) As Long
Private Declare Function GdipDisposeImage Lib "gdiplus.dll" (ByVal image As Long) As Long
Private Declare Function GdipDrawImageRectI Lib "gdiplus" (ByVal graphics As Long, ByVal image As Long, ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Declare Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As Long, graphics As Long) As Long
Private Declare Function GdipGetImageHeight Lib "gdiplus" (ByVal image As Long, Height As Long) As Long
Private Declare Function GdipGetImageWidth Lib "gdiplus" (ByVal image As Long, Width As Long) As Long
Private Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As Long
Private Declare Function GdipSaveImageToFile Lib "gdiplus.dll" (ByVal image As Long, ByVal fileName As Long, ByRef clsidEncoder As uuid, ByVal encoderParams As Long) As Long

'===== GDI無印関係等
Private Const PICTYPE_BITMAP = 1        'pictdescに与えるpictureのタイプ
Private Const PICTYPE_ENHMETAFILE = 4
Private Const DIB_RGB_COLORS = 0&

Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function CreateDIBSection Lib "gdi32.dll" (ByVal hdc As Long, pbmi As BITMAPINFO, ByVal iUsage As Long, ppvBits As Long, ByVal hSection As Long, ByVal dwOffset As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hgdiobj As Long) As Long
Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
Private Declare Function SetPixelV Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal crColor As Long) As Long

'===== enhancedmetafile関係
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 GetEnhMetaFile Lib "gdi32" Alias "GetEnhMetaFileA" (ByVal lpszMetaFile As String) As Long
Private Declare Function GetMetaFile Lib "gdi32" Alias "GetMetaFileA" (ByVal lpFileName As String) As Long
Private Declare Function GetMetaFileBitsEx Lib "gdi32" (ByVal hmf As Long, ByVal nSize As Long, lpvData As Any) As Long
Private Declare Function GetEnhMetaFileHeader Lib "gdi32" (ByVal hEmf As Long, ByVal MetaHeaderSize As Long, ByRef MetaHeader As ENHMETAHEADER) As Long
Private Declare Function PlayEnhMetaFile Lib "gdi32" (ByVal hdc As Long, ByVal hEmf As Long, lpRect As RECT) As Long
Private Declare Function SetWinMetaFileBits Lib "gdi32" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As Long, lpmfp As METAFILEPICT) As Long
Private Declare Function SetWinMetaFileBitsByNull Lib "gdi32" Alias "SetWinMetaFileBits" (ByVal cbBuffer As Long, lpbBuffer As Byte, ByVal hdcRef As Long, lpmfp As Long) As Long

Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetLastError Lib "KERNEL32" () As Long
Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long

Private Declare Function CLSIDFromString Lib "ole32" (ByVal lpszCLSID As Long, ByRef pclsid As uuid) As Long

'===== Clipboard関係
Const CF_ENHMETAFILE = 14

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
  
'Usage
Sub test()
  '引数は元画像サイズの何倍にするか、解像度dpi
  saveRangeAsHipixelJpeg GetDesktopPath & "\" & "rangeToHighPix.jpg", 2, 200
End Sub

Private Sub saveRangeAsHipixelJpeg(strOutName As String, multiplyingFactor As Long, myDpi As Long)
  Dim hBmp As Long
  Dim hbmpOld As Long
  Dim hdc As Long, hdcDesktop As Long
  Dim hEmf As Long '拡張メタファイルのハンドル
  Dim r As RECT '描画する領域
  Dim mh As ENHMETAHEADER '取得結果のメタファイルヘッダ
  Dim emfWidth As Long, emfHeight As Long
  Dim bmpInfo As BITMAPINFO
  Dim GDIsi As GdiplusStartupInput, gToken As Long
  Dim fileName As String
  Dim encBMP As uuid
  Dim pNewImage As Long, nStatus As Long, pDstBmp As Long, pGraphics As Long
  Dim i As Long, j As Long
  Dim lngWidth As Long, lngHeight As Long
 
  Const DIB_RGB_COLORS As Long = 0        ' RGBパタン
  
  If TypeName(Selection) <> "Range" Then Exit Sub
  Selection.CopyPicture Appearance:=xlPrinter, Format:=xlPicture
  
  'クリップボードからemf形式で取得
  If OpenClipboard(0) Then
    hEmf = GetClipboardData(CF_ENHMETAFILE)
    ' ハンドルを複製してから使用する
    hEmf = CopyEnhMetaFile(hEmf, vbNullString)
    CloseClipboard
  End If
  If hEmf = 0 Then
    MsgBox "emf取得に失敗"
    Exit Sub
  End If
 
  'GDI+初期化
  On Error Resume Next
  GDIsi.GdiplusVersion = 1&
  GdiplusStartup gToken, GDIsi, 0&
  If Err Then
    Err.Clear
    Exit Sub
  ElseIf gToken = 0& Then
    Exit Sub
  End If
  On Error GoTo 0
  
  'emfヘッダからサイズの取得
  GetEnhMetaFileHeader hEmf, Len(mh), mh
  With mh
     emfWidth = .rclBounds.Right - .rclBounds.Left
     emfHeight = .rclBounds.Bottom - .rclBounds.Top
  End With
  'デスクトップ互換のデバイスコンテキスト生成
  hdcDesktop = GetDC(0)
  hdc = CreateCompatibleDC(hdcDesktop)
  
  With bmpInfo.bmiHeader '構造体初期化
    .biSize = 40
    .biWidth = emfWidth * multiplyingFactor
    .biHeight = emfHeight * multiplyingFactor
    .biPlanes = 1
    .biBitCount = 24 '２４ビット
    .biCompression = 0 'BI_RGB
    .biSizeImage = 0 'BI_RGBの時は０
    .biClrUsed = 0
  End With
  Dim hDIB As Long
   'DIB作成
  hBmp = CreateDIBSection(hdc, bmpInfo, DIB_RGB_COLORS, 0, 0, 0)
  hbmpOld = SelectObject(hdc, hBmp)
  '描画領域の設定
  r.Left = 0
  r.Top = 0
  r.Right = emfWidth * multiplyingFactor
  r.Bottom = emfHeight * multiplyingFactor
    
  '透明背景に黒文字だとbmpが真っ黒になるため、背景を白で塗りつぶし
  For i = 0 To emfWidth * multiplyingFactor - 1
    For j = 0 To emfHeight * multiplyingFactor - 1
      Call SetPixelV(hdc, i, j, &HFFFFFF)
    Next j
  Next i

  '拡張メタファイルの描画
   Call PlayEnhMetaFile(hdc, hEmf, r)
   
  'デバイス依存ビットマップオブジェクトHBITMAPから、ビットマップオブジェクトに変換
  'デスクトップ互換DCに描画しているので、当然デバイス依存になっていると考えれば良い？
  nStatus = GdipCreateBitmapFromHBITMAP(hBmp, 0&, pNewImage)
 
  ' 元画像サイズの取得
  GdipGetImageWidth pNewImage, lngWidth
  GdipGetImageHeight pNewImage, lngHeight
  
  ' コピー先Bitmap作成
  nStatus = GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat24bppRGB, ByVal 0&, pDstBmp)
  
  'dpiの指定
  nStatus = GdipBitmapSetResolution(pDstBmp, myDpi, myDpi)
  If nStatus = 0 Then
    ' コピー用Graphics作成
    If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
        '白で初期化
        GdipGraphicsClear pGraphics, &HFFFFFFFF
        
        ' イメージのコピー
        GdipDrawImageRectI pGraphics, pNewImage, 0, 0, lngWidth, lngHeight
        
        'Graphicsの始末
        GdipDeleteGraphics pGraphics
    End If
  End If
  
  'BMP保存
'  strOutName = GetDesktopPath & "\emf2bmpKai.bmp"
'  CLSIDFromString StrPtr("{557CF400-1A04-11D3-9A73-0000F81EF32E}"), encBMP
'  GdipSaveImageToFile pDstBmp, StrPtr(strOutName), encBMP, ByVal 0&

  'Jpeg保存
'  strOutName = GetDesktopPath & "\emf2bmpKai.jpg"
  SaveImageToFile pDstBmp, strOutName, "JPG", 90
  
  '後始末
  GdipDisposeImage pDstBmp
  GdipDisposeImage pNewImage
  GdiplusShutdown gToken
  
  SelectObject hdc, hbmpOld
  DeleteObject hBmp
  DeleteDC hdc
  DeleteEnhMetaFile hEmf
  
End Sub

' // 文字列から CLSID を取得する
Private Function pvToCLSID(ByVal S As String) As uuid
    CLSIDFromString StrPtr(S), pvToCLSID
End Function

' // GDI+ hBitmap からファイルへ書き出し
'KenKenSPさんのコードを小変更 GdipCreateBitmapFromHBITMAPを削除
Public Function SaveImageToFile( _
    ByVal hBmp As OLE_HANDLE, _
    ByVal sFilename As String, _
    Optional ByVal sFormat As String = "JPG", _
    Optional ByVal nQuarity As Long = 90 _
) As Boolean
    
    Dim sEncoderStr As String
    Dim uEncoderParams   As EncoderParameters
    Dim nStatus   As Long
    
    If hBmp = 0 Then Exit Function
    Select Case UCase$(sFormat)
        Case "JPG": sEncoderStr = ENCODER_JPG
        Case "GIF": sEncoderStr = ENCODER_GIF
        Case "TIF": sEncoderStr = ENCODER_TIF
        Case "PNG": sEncoderStr = ENCODER_PNG
        Case Else: sEncoderStr = ENCODER_BMP
    End Select
    ' Jpeg のクオリティー設定
    If UCase$(sFormat) = "JPG" Then
        nQuarity = Abs(nQuarity)
        If nQuarity > 100 Then nQuarity = 100
        uEncoderParams.Count = 1
        With uEncoderParams.Parameter(0)
            .uuid = pvToCLSID(QUALITY_PARAMS)
            .Type = 4 ' Type Long
            .Value = VarPtr(nQuarity)
            .NumberOfValues = 1
        End With
    End If
    
    ' 保存処理
    If nStatus = 0 Then
        If UCase$(sFormat) = "JPG" Then
            nStatus = GdipSaveImageToFile(hBmp, _
                                          StrPtr(sFilename), _
                                          pvToCLSID(sEncoderStr), _
                                          VarPtr(uEncoderParams))
        Else
            nStatus = GdipSaveImageToFile(hBmp, _
                                          StrPtr(sFilename), _
                                          pvToCLSID(sEncoderStr), _
                                          ByVal 0&)
        End If
        SaveImageToFile = CBool(nStatus = 0)
        Call GdipDisposeImage(hBmp)
    End If
End Function

' // クリップボード hBitmap を取得する
Private Function pvGetHBitmapFromClipboard() As OLE_HANDLE
    If OpenClipboard(0&) <> 0 Then
        pvGetHBitmapFromClipboard = GetClipboardData(CF_BITMAP)
        Call CloseClipboard
    Else
        pvGetHBitmapFromClipboard = 0
    End If
End Function

Private Function GetDesktopPath() As String
  Dim wScriptHost As Object, strInitDir As String
  Set wScriptHost = CreateObject("Wscript.Shell")
  GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
  Set wScriptHost = Nothing
End Function
選択範囲を高画素数・高解像度Jpegで保存
