「教えて!ピックアップ」リリース!

ACCESS VBAで画像ファイルの大きさ(バイト数では無く、ピクセル 幅x高さ)を取得したいです。

やりたい事は”スキャナしたA4、A3混在の複数のTIFF形式のファイル(マルチページ形式では無い)をサイズ判別して、それぞれ別レポートで元のサイズで印刷”です。

用紙サイズの判別に上記の 幅x高さを利用しようと考えています。
バイト数の取得(FileLen)の様な単純な方法は無いですか?

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

A 回答 (3件)

確認してみたら 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
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/07/22 19:25

方法はいろいろあると思いますけど、たとえば 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

などだったと思います。
    • good
    • 0

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
    • good
    • 0
この回答へのお礼

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

お礼日時:2009/07/22 19:33

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


人気Q&Aランキング