画像の解像度と色深度を変更する

Public Type GdiplusStartupInput
    GdiplusVersion           As Long
    DebugEventCallback       As Long
    SuppressBackgroundThread As Long
    SuppressExternalCodecs   As Long
End Type

Public Type GUID
    Data1 As Long
    Data2 As Integer
    Data3 As Integer
    Data4(0 To 7) As Byte
End Type

Public Type EncoderParameter
    GUID           As GUID
    NumberOfValues As Long
    Type           As Long
    Value          As Long
End Type

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

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

Public Const CLSID_JPEG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Public Const CLSID_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Public Const CLSID_QUALITY As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Public Const CLSID_COLORDEPTH As String = "{66087055-ad66-4c7c-9a18-38a2310b8337}"

Public Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
        (FileName As Any, bitmap As Long) As Long
Public Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
        (ByVal Width As Long, ByVal Height As Long, _
        ByVal Target As Long, bitmap As Long) As Long
Public Declare Function GdipDeleteGraphics Lib "gdiplus" _
        (ByVal graphics As Long) As Long
Public Declare Function GdipDisposeImage Lib "gdiplus" _
        (ByVal image As Long) As Long
Public 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
Public Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
        (ByVal image As Long, graphics As Long) As Long
Public Declare Function GdipGetImageHeight Lib "gdiplus" _
        (ByVal image As Long, Height As Long) As Long
Public Declare Function GdipGetImageWidth Lib "gdiplus" _
        (ByVal image As Long, Width As Long) As Long
Public Declare Function GdipSaveImageToFile Lib "gdiplus" ( _
        ByVal image As Long, _
        ByVal FileName As Long, _
        ByRef clsidEncoder As GUID, _
        ByVal encoderParams As Any) As Long
Public Declare Sub GdiplusShutdown Lib "gdiplus" _
        (ByVal token As Long)
Public Declare Function GdiplusStartup Lib "gdiplus" _
        (token As Long, pInput As GdiplusStartupInput, _
        pOutput As Any) As Long
Public Declare Function GdipBitmapSetResolution Lib "gdiplus" (ByVal bitmap As Long, ByVal xdpi As Single, ByVal ydpi As Single) As Long
Public Declare Function CLSIDFromString Lib "ole32.dll" ( _
        ByVal lpszCLSID As Long, _
        ByRef pCLSID As GUID) As Long
Public Declare Function GdipCreateBitmapFromScan0 Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal stride As Long, ByVal PixelFormat As Long, scan0 As Any, bitmap As Long) As Long
Public Declare Function GdipCloneBitmapArea Lib "gdiplus" (ByVal x As Single, ByVal y As Single, ByVal Width As Single, ByVal Height As Single, ByVal PixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As Long
Public Declare Function GdipCloneBitmapAreaI Lib "gdiplus" (ByVal x As Long, ByVal y As Long, ByVal Width As Long, ByVal Height As Long, ByVal PixelFormat As Long, ByVal srcBitmap As Long, dstBitmap As Long) As Long
Public Declare Function GdipGraphicsClear Lib "gdiplus" (ByVal graphics As Long, ByVal lColor As Long) As Long

Sub changeDPIandDepth()
    Dim IID_IDispatch As GUID
    Dim udtInput  As GdiplusStartupInput
    Dim lngToken  As Long, lngStatus As Long
    Dim pGraphics As Long
    Dim pSrcBmp   As Long, pDstBmp As Long
    Dim lngWidth  As Long, lngHeight As Long
    Dim srcPath As String, dstPath As String
    Const myDpi As Long = 300
     
    srcPath = GetDesktopPath & "\sample1.jpg"
    dstPath = GetDesktopPath & "\sample2.png"
    
    ' 初期化
    udtInput.GdiplusVersion = 1
    If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
        Exit Sub
    End If

    ' 画像の読みこみ
    If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
        GdiplusShutdown lngToken
        Exit Sub
    End If

    ' 元画像サイズの取得
    GdipGetImageWidth pSrcBmp, lngWidth
    GdipGetImageHeight pSrcBmp, lngHeight
    
    ' コピー先Bitmap作成
    lngStatus = GdipCreateBitmapFromScan0(lngWidth, lngHeight, 0, PixelFormat32bppARGB, ByVal 0&, pDstBmp)
    
    'dpiの指定
    lngStatus = GdipBitmapSetResolution(pDstBmp, myDpi, myDpi)
    
    If lngStatus = 0 Then
        ' コピー用Graphics作成
        If GdipGetImageGraphicsContext(pDstBmp, pGraphics) = 0 Then
            '白で初期化
            GdipGraphicsClear pGraphics, &HFFFFFFFF
            
            ' イメージのコピー
            GdipDrawImageRectI pGraphics, pSrcBmp, 0, 0, lngWidth, lngHeight
            
            'Graphicsの始末
            GdipDeleteGraphics pGraphics
            
            '色深度32bitをサポートしているPNG形式で保存
            Call GdipSaveImageToFile(pDstBmp, StrPtr(dstPath), ConvCLSID(CLSID_PNG), ByVal 0&)
        End If
        GdipDisposeImage pDstBmp
    End If
    GdipDisposeImage pSrcBmp
    GdiplusShutdown lngToken
End Sub

Private Function ConvCLSID(ByVal sGuid As String) As GUID
    CLSIDFromString StrPtr(sGuid), ConvCLSID
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