ＡＣＣＥＳＳ ＶＢＡ 画像ファイルの大きさ（幅ｘ高さ）を取得したい

質問

ＡＣＣＥＳＳ ＶＢＡで画像ファイルの大きさ（バイト数では無く、ピクセル 幅ｘ高さ）を取得したいです。

やりたい事は”スキャナしたＡ４、Ａ３混在の複数のＴＩＦＦ形式のファイル（マルチページ形式では無い）をサイズ判別して、それぞれ別レポートで元のサイズで印刷”です。

用紙サイズの判別に上記の 幅ｘ高さを利用しようと考えています。
バイト数の取得（ＦｉｌｅＬｅｎ）の様な単純な方法は無いですか？

いろいろ調べてはみたのですが見付かりませんでした。
初心者ではありますが、どうしても必要なので多少複雑になっても勉強して理解しようと思います。
宜しくお願いします。

回答No.3

KenKen_SP · ベストアンサー

確認してみたら LoadPicture では TIF ファイルを読み込めなかったですね。
すみません。JPG や BMP なら大丈夫ですが・・・

TIF に対応した GDI+ を使った方法を改めて紹介します。

Private Declare Function GdiplusStartup Lib "gdiplus" ( _
　　　　ByRef token As Long, _
　　　　ByRef inputBuf As GdiplusStartupInput, _
　　　　ByVal outputBuf As Long) As Long
Private Declare Sub GdiplusShutdown Lib "gdiplus" ( _
　　　　ByVal token As Long)
Private Declare Function GdipLoadImageFromFile Lib "gdiplus" ( _
　　　　ByVal FileName As Long, _
　　　　ByRef image As Long) As Long
Private Declare Function GdipGetImageDimension Lib "gdiplus" ( _
　　　　ByVal image As Long, _
　　　　ByRef Width As Single, _
　　　　ByRef Height As Single) As Long

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

' // 画像の幅と高さをピクセルで取得する
Public Function GetImageDimensionFromFile( _
　　ByVal sImageFilePath As String, _
　　ByRef x As Long, _
　　ByRef y As Long _
) As Boolean

　　'@ 対応フォーマット : BMP, JPG, GIF, TIF, PNG,

　　Dim uGdiStartupInput As GdiplusStartupInput
　　Dim nGdiToken　　　　As Long
　　Dim nStatus　　　　　As Long
　　Dim hImage　　　　　 As Long
　　Dim xx　　　　　　　 As Single
　　Dim yy　　　　　　　 As Single

　　x = 0: y = 0
　　With uGdiStartupInput
　　　　.GdiplusVersion = 1
　　End With
　　nStatus = GdiplusStartup(nGdiToken, uGdiStartupInput, 0&)
　　If nStatus = 0 Then
　　　 nStatus = GdipLoadImageFromFile(ByVal StrPtr(sImageFilePath), _
　　　　　　　　　　　　　　　　　　　 hImage)
　　　 If nStatus = 0 Then
　　　　　nStatus = GdipGetImageDimension(hImage, xx, yy)
　　　　　If nStatus = 0 Then
　　　　　　 GetImageDimensionFromFile = True
　　　　　　 x = xx
　　　　　　 y = yy
　　　　　End If
　　　 End If
　　　　Call GdiplusShutdown(nGdiToken)
　　End If

End Function

Sub sample()

　　Dim x　 As Long
　　Dim y　 As Long

　　If GetImageDimensionFromFile("C:\test3.tif", x, y) Then
　　　　MsgBox CStr(x) & " x " & CStr(y) & " pix"
　　Else
　　　　MsgBox "失敗"
　　End If

End Sub

お礼

早速のご回答ありがとうございました。
おかげ様で目的のＡ３、Ａ４の振り分け出力まで完成しました。
数ヶ月越しで悩んでいたので感動です。
流れもだいたい解りすごく勉強になりました。
ありがとうございました。
また何かありましたら宜しくお願い致します。

回答No.2

KenKen_SP

方法はいろいろあると思いますけど、たとえば LoadPicture 関数を使った方法

　　Dim pic As stdole.IPictureDisp
　　Set pic = LoadPicture("C:\test.tif")

でオブジェクト変数 pic の Width、Height プロパティーで画像の幅や高さを
調べることができます。

ただし、そのままでは HIMETRIC という単位なので、PIXEL に変換してやる
必要がありますよね。VBA の場合、Screen オブジェクトが利用できませんので、
下記のような単位変換のユーザー定義関数を用意することになります。

' 標準モジュール

Private Declare Function GetDC Lib "user32.dll" ( _
　　　　ByVal hWnd As Long) As Long
Private Declare Function ReleaseDC Lib "user32.dll" ( _
　　　　ByVal hWnd As Long, _
　　　　ByVal hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32.dll" ( _
　　　　ByVal hdc As Long, _
　　　　ByVal nIndex As Long) As Long
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90

' Himetric --> Pixel 変換関数
Public Function Himetric2PixelX(ByVal x As Long) As Long
　　Static m As Single
　　Dim hdc　As OLE_HANDLE
　　If m = 0 Then
　　　 hdc = GetDC(0&)
　　　 m = GetDeviceCaps(hdc, LOGPIXELSX) / 2540
　　　 Call ReleaseDC(0&, hdc)
　　End If
　　Himetric2PixelX = CLng(x * m)
End Function

Public Function Himetric2PixelY(ByVal y As Long) As Long
　　Static m As Single
　　Dim hdc　As OLE_HANDLE
　　If m = 0 Then
　　　 hdc = GetDC(0&)
　　　 m = GetDeviceCaps(hdc, LOGPIXELSY) / 2540
　　　 Call ReleaseDC(0&, hdc)
　　End If
　　Himetric2PixelY = CLng(y * m)
End Function

このような関数を用意すればあとは、下記のようなソースでピクセルが求まる
と思います。

Sub sample()

　　Dim pic As stdole.IPictureDisp
　　Dim x　 As Long
　　Dim y　 As Long

　　Set pic = LoadPicture("C:\test.tif")
　　x = Himetric2PixelX(pic.Width)
　　y = Himetric2PixelY(pic.Height)
　　MsgBox CStr(x) & " x " & CStr(y) & " pix"

End Sub

なお、LoadPicture 関数で対応できるファーマットは

　　bmp, jpg, emf, wmf, gif, ico

などだったと思います。

回答No.1

nda23

Sub TIF解析(ファイル名$, 幅&, 高さ&)
Dim 位&, 数&, 番&, 済&
ReDim 域(0) As Byte
番 = FreeFile
Open ファイル名 For Binary As 番
ReDim 域(3)
Get 番, 5, 域
位 = 数値化(域)
ReDim 域(1)
Get 番, 位 + 1, 域
数 = 数値化(域)
位 = 位 + 2
Do Until 数 = 0
　　ReDim 域(1)
　　Get 番, 位 + 1, 域
　　Select Case 数値化(域)
　　　　Case &H100 '幅
　　　　　　幅 = 値取得(番, 位)
　　　　　　済 = 済 Or 1
　　　　Case &H101 '高さ
　　　　　　高さ = 値取得(番, 位)
　　　　　　済 = 済 Or 2
　　End Select
　　If 済 = 3 Then Exit Do
　　位 = 位 + 12
　　数 = 数 - 1
Loop
Close 番
End Sub
Function 値取得&(番&, 位&)
ReDim 域(1) As Byte
Get 番, 位 + 3, 域
If 数値化(域) = 4 Then ReDim 域(3)
Get 番, 位 + 9, 域
値取得 = 数値化(域)
End Function
Function 数値化&(域() As Byte)
Dim 値&
値 = 域(0) + 域(1) * &H100
If UBound(域) > 1 Then
　　値 = 値 + 域(2) * &H10000 + 域(3) * &H1000000
End If
数値化 = 値
End Function

お礼

早速のご回答ありがとうございました。
nda23様のご回答何回で私には難解で未だ解読できていません。
申し訳ございません。
とりあえず目的は達しましたので、今後解読して勉強させて頂きます。
ありがとうございました。
また何かありましたら宜しくお願い致します。