GDIplusCODE


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

Private Declare Function GdipCreateBitmapFromFile Lib "Gdiplus" (FileName As Any, bitmap As Long) As Long
Private Declare Function GdipDisposeImage Lib "Gdiplus" (ByVal Image 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 Sub GdiplusShutdown Lib "Gdiplus" (ByVal token As Long)
Private Declare Function GdiplusStartup Lib "Gdiplus" (token As Long, pInput As GdiplusStartupInput, pOutput As Any) As Long

Function GetImageSize(ByVal f As File, ByRef x As Long, ByRef y As Long) As Boolean
  Dim udtInput As GdiplusStartupInput
  Dim lngToken As Long, lngStatus As Long
  Dim pSrcBmp As Long, pDstBmp As Long
  Dim lngWidth As Long, lngHeight As Long
  Dim srcPath As String
  
  srcPath = f.Path
  udtInput.GdiplusVersion = 1
  If GdiplusStartup(lngToken, udtInput, ByVal 0&) <> 0 Then
    GetImageSize = False
    Exit Function
  End If
  If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath), pSrcBmp) <> 0 Then
    GdiplusShutdown lngToken
    GetImageSize = False
    Exit Function
  End If
  GdipGetImageWidth pSrcBmp, lngWidth
  GdipGetImageHeight pSrcBmp, lngHeight
  x = lngWidth
  y = lngHeight

  GdipDisposeImage pSrcBmp
  GdiplusShutdown lngToken
  GetImageSize = True
End Function

Sub main()
  Dim FSO As New FileSystemObject
  Dim FLD As Folder
  Dim FLE As File
  Dim FF As File
  Dim x As Long
  Dim y As Long
  Dim myCnt As Long
  
  Set FLD = FSO.GetFolder(GetDesktopPath & "\picsizetest")
  For Each FF In FLD.Files
    If GetImageSize(FF, x, y) Then
      myCnt = myCnt + 1
      Cells(myCnt, "A").Value = FF.Name
      Cells(myCnt, "B").Value = x
      Cells(myCnt, "C").Value = y
    End If
  Next FF
End Sub

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

'解像度(dpi)の取得
'Private Declare Function GdipGetImageHorizontalResolution Lib "Gdiplus" (ByVal Image As Long, resolution As Single) As Long
'Private Declare Function GdipGetImageVerticalResolution Lib "Gdiplus" (ByVal Image As Long, resolution As Single) As Long
'  Dim horResln As Single, verResln As Single
'  GdipGetImageHorizontalResolution pSrcBmp, horResln
'  GdipGetImageVerticalResolution pSrcBmp, verResln
'  Debug.Print horResln, verResln
各種画像ファイルのサイズ（ピクセル数）取得
