フォルダーに入った画像名の取得したい

質問

ＶＢ初心者です。色々調べて、セルに「画像名と画像サイズ一覧」を
書き出すことができました。

しかし、書き出せたのはjpgだけで、gifやpngをフォルダー内に入れると
エラーが・・・・

どうしたらgifやpngも書き出せるコードになるか教えてください。

よろしくお願いします。

書いたコードは下記です。

Sub GetImageSize(ByVal f, ByRef x, ByRef y)
Dim p
Set p = LoadPicture(f)
x = CLng(CDbl(p.Width) * 24 / 635)
y = CLng(CDbl(p.Height) * 24 / 635)
Set p = Nothing
End Sub
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
Set FLD = FSO.GetFolder("C:\画像の入ったフォルダー名")
For Each FF In FLD.Files
Call GetImageSize(FF, x, y)

Name = FF.Name
Name_x = x
Name_y = y

myCnt = myCnt + 1
Cells(myCnt, "A").Value = FF.Name
Cells(myCnt, "B").Value = x
Cells(myCnt, "C").Value = y

Next FF
End Sub

回答No.1

mitarashi · ベストアンサー

LoadPictureはgifやpngには対応していませんので、最近のWindowsなら標準で持っているGDI+という機能を用いています。なるべく元の形に添わせました。簡便さ優先で毎回GDI+のオブジェクトを生成しているので、重たいと思います。ご参考まで。
（訳の分からないものを使うのは嫌という場合は、他の回答者様の回答をお待ち下さい。）Windows7Home(64bit),xl2010で試しています。

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

お礼

mitarashiさん

大変ありがとうございます！
jpg gif png全て書き出せました^^

gif pngに対応するために、２，３行追加すればなんて、
甘いこを考えていた昨日の自分・・・

ご丁寧にコードまで書いて頂き大変感謝しております！

本当にありがとうございました。