[[20230711085454]]　『Excel VBA マルチtiffのページごとに用紙サイズ潤x（たまりん）　ページの最後に飛ぶ

『Excel VBA マルチtiffのページごとに用紙サイズ情報取得』（たまりん）

お世話になっています
複数ページのマルチTIFデータの各ページごとに
用紙サイズ、枚数を取得することはできますでしょうか

以前作ったマクロは複数ファイルを同時に確認し
B列にファイル名、C列にページ数　D列に横サイズ　E列に縦サイズ
を取得するものを作ったのですが、この時は同じ縦横比だったので何とかなったのですが、ファイル内でサイズ違いがある場合の対応ができません

複数ファイルを同時に確認し、1データ内に用紙サイズが異なる場合はB列のファイル名は最初だけ記載し別データを読み込んだときはそのファイル名を最初だけ記載ということができればなおいいのですが
例として以下の3ファイルを読み込んだ場合、
ファイル１が297×420が2、210×297が6
ファイル２が210×297が5
ファイル３が297×420が4、148×210が5
以下のように出力されるようにできませんでしょうか
B列（ファイル名）　C列（横）　D列（縦）　E列（枚数）
ファイル１　　　　297　　　　　420　　　　2
　　　　　　　　　210　　　　　297　　　　6
ファイル２　　　　210　　　　　297　　　　5
ファイル３　　　　297　　　　　420　　　　4
　　　　　　　　　148　　　　　210　　　　5

宜しくお願いいたします
以下は以前のマクロです
いろいろなサイト情報をつぎはぎして作成したので見苦しいかもしれませんが、、、

Type T_HeaderDecorder

    ByteOrder As String * 2     '  “II(4949) or MM(4D4D)
    TiffCode As Integer         '   = 42
End Type
Type T_Tag
    TagType(0 To 1) As Byte
    DataType(0 To 1) As Byte
    DataCount As Long
    Data(0 To 3) As Byte
End Type

Sub ファイル情報取得()
Dim F_name As String
Dim pWidth As Single
Dim pheight As Single
Dim CountNo As Long
Dim FolderName As String
Dim Filename As String

'画面の更新をOFF
Application.ScreenUpdating = False
'自動計算手動
Application.Calculation = xlManual

 '実行ファイルのあるフォルダへのパス取得
FolderName = ActiveWorkbook.Path & "\画像データ\" ' 回答データフォルダのフルパス
Filename = Dir(FolderName & "*tif")  ' フォルダの中に含まれるファイルを取り出す

If Filename = "" Then

    'メッセージを表示
    MsgBox "データがありません。", vbExclamation
    'エラー検出終了
    Exit Sub
End If

CountNo = 0

'開いたファイルから取得した社名をリストと照合
DoEvents
Do While Filename <> "" ' ファイルがなくなるまで繰り返す

    CountNo = CountNo + 1
    'ファイル名記載
    Cells(2 + CountNo, 2) = Filename
    'ページ数記載
    F_name = FolderName & Filename
    Cells(2 + CountNo, 3) = GetPageNumber(FolderName & Filename)

    'ファイルサイズ取得
    Call ファイルサイズ取得(F_name, pWidth, pheight)
    'ファイルサイズ記載
    Cells(2 + CountNo, 4) = pWidth
    Cells(2 + CountNo, 5) = pheight

    '次のファイル名を格納
    Filename = Dir() '
Loop

DoEvents

'画面の更新をON
Application.ScreenUpdating = True
'自動計算自動
Application.Calculation = xlAutomatic

MsgBox "作業終了しました。"

End Sub
Function GetPageNumber(TiffFileName As String)

    Dim header As T_HeaderDecorder
    Dim TagSize As Integer, Tag() As T_Tag, NextIFD As Long
    Dim pagecount As Long
    fn = FreeFile
    Open TiffFileName For Binary As fn
    Get fn, , header
    If header.ByteOrder <> "II" Then Close: Err.Raise 9999, , "バイトオーダーが違います", vbCritical
    If header.TiffCode <> 42 Then Close: Err.Raise 9999, , "Tiffファイルではありません", vbCritical
    pagecount = 0
    Do While Not EOF(fn)
        Get fn, , NextIFD
        If NextIFD = 0 Then Exit Do
        Seek #fn, NextIFD + 1
        pagecount = pagecount + 1
        Get fn, , TagSize
        If TagSize > 0 Then
            ReDim Tag(1 To TagSize)
            Get fn, , Tag
        End If
    Loop
    Close fn
    GetPageNumber = pagecount
End Function

Sub ファイルサイズ取得(F_name As String, pWidth As Single, pheight As Single)

    Dim sp As Shape
    Dim strFile As String

    If F_name = "False" Then
        Exit Sub
    End If
    'Stop
    Set sp = ActiveSheet.Shapes.AddPicture( _
                Filename:=F_name, _
                LinkToFile:=False, _
                SaveWithDocument:=True, _
                Left:=0, _
                Top:=0, _
                Width:=0, _
                Height:=0 _
                )
    With sp

        .LockAspectRatio = False
        .ScaleHeight 1, msoTrue, msoScaleFromTopLeft
        .ScaleWidth 1, msoTrue, msoScaleFromTopLeft

        pWidth = Round(.Width / 72 * 25.4, 0)
        pheight = Round(.Height / 72 * 25.4, 0)

        .Delete
    End With

End Sub

＜使用 Excel：Microsoft365、使用 OS：Windows10 ＞

 記憶が定かではありませんが、こちらの話の続きですね
[[20211019133832]]　『マルチtiffのページ数 取得』（たまりん）

 こちらのサイトが参考になります。
https://zenn.dev/mith_mmk/articles/076ef011b063fa

 現状のGetPageNumber関数では、Tag（参考サイトのDirectory Entry）を読み飛ばしていますが、
 ちゃんと読み込んで、ImageWidth、ImageLength、XResolution、YResolution、ResolutionUnit の値が分かれば、
 ページサイズも計算できるんじゃないかなぁ．．．と思います。
（´・ω・`） 2023/07/11(火) 10:41:33

 PageInfoにサイズの情報などが返ってきます
 1ページだけのTifではとりあえず成功しました
 マルチページTifでのテストはしてません(今手元にないので)

 Type T_HeaderDecorder
    ByteOrder As String * 2     '  “II(4949) or MM(4D4D)
    TiffCode As Integer         '   = 42
 End Type

 Type T_Tag
    TagType As Integer
    DataType As Integer
    DataCount As Long
    Data As Long
 End Type

 Type T_PageInfo
    ImageWidth As Long         ' 縦
    ImageHeight As Long        ' 横
    XResolution As Long
    YResolution As Long
    ResolutionUnit As Long
    PaseWidth As Double
    PaseHeight As Double
 End Type

 Sub sample()
    Dim PageInfo() As T_PageInfo
    Debug.Print GetPageNumber("D:\ほげほげ.tif", PageInfo)
    Stop
 End Sub

 Function GetPageNumber(TiffFileName As String, PageInfo() As T_PageInfo)
    Dim header As T_HeaderDecorder
    Dim TagSize As Integer, Tag() As T_Tag, NextIFD As Long
    Dim pagecount As Long, d1(0 To 1) As Long
    fn = FreeFile
    Open TiffFileName For Binary As fn
    Get fn, , header
    If header.ByteOrder <> "II" Then Close: Err.Raise 9999, , "バイトオーダーが違います", vbCritical
    If header.TiffCode <> 42 Then Close: Err.Raise 9999, , "Tiffファイルではありません", vbCritical
    pagecount = 0
    Get fn, , NextIFD
    If NextIFD > 0 Then
        Do While Not EOF(fn)
            Seek #fn, NextIFD + 1
            pagecount = pagecount + 1
            Get fn, , TagSize
            If TagSize > 0 Then
                ReDim Tag(1 To TagSize)
                Get fn, , Tag
            End If
            Get fn, , NextIFD
            ReDim Preserve PageInfo(1 To pagecount)
            For i = 1 To TagSize
                Select Case Tag(i).TagType
                   Case &H100
                      PageInfo(pagecount).ImageWidth = Tag(i).Data
                   Case &H101
                      PageInfo(pagecount).ImageHeight = Tag(i).Data
                   Case &H11A
                      Seek #fn, Tag(i).Data + 1
                      Get fn, , d1
                      PageInfo(pagecount).XResolution = d1(0) / d1(1)
                   Case &H11B
                      Seek #fn, Tag(i).Data + 1
                      Get fn, , d1
                      PageInfo(pagecount).YResolution = d1(0) / d1(1)
                   Case &H128
                      PageInfo(pagecount).ResolutionUnit = Tag(i).Data
                End Select
            Next
            PageInfo(pagecount).PaseWidth = PageInfo(pagecount).ImageWidth / PageInfo(pagecount).XResolution
            PageInfo(pagecount).PaseHeight = PageInfo(pagecount).ImageHeight / PageInfo(pagecount).YResolution
            If PageInfo(pagecount).ResolutionUnit = 2 Then
                PageInfo(pagecount).PaseWidth = PageInfo(pagecount).PaseWidth * 25.4
                PageInfo(pagecount).PaseHeight = PageInfo(pagecount).PaseHeight * 25.4
            End If
            If NextIFD = 0 Then Exit Do
        Loop
    End If
    Close fn
    GetPageNumber = pagecount
 End Function
（´・ω・`） 2023/07/11(火) 12:56:20

（´・ω・`）さん
前回もお世話になっていましたね、本当にありがとうございます
参考サイトは見てみましたが、VBAの適用例が無いため、他サイトなども閲覧しながら
解析しようと思っていましたが、なかなかいい情報が無く途方に暮れていました
前回もサイズを取得できず、Excelに取り込んだ後、画像サイズを取得するという
へんな対応をしていました
Tagの取得でサイズも取得できそうなのは何となくわかっていたのですが
ぴったりの紹介サイトが見つからず、
サイズが同一のマルチTIFだったので上記のようなマクロで対応してました

当方、現在テストできる環境にいないため、明日確認させていただきます
宜しくお願いいたします
（たまりん） 2023/07/11(火) 16:00:06

（´・ω・`）さん
お世話になります
マクロの検証を行いました
マルチTIFも問題なく取得できました

フォルダーを指定し中に入っている複数ファイルへの対応も
前回当方で書いた部分を改良することで対応することができました
TifデータのTagとPageInfoの取得部分は理解が追い付かないので勉強してみます
前回に引き続き、本当にありがとうございました
（たまりん） 2023/07/12(水) 09:21:18

コメント返信：

[ 一覧(最新更新順) ]

[[20230711085454]] 『Excel VBA マルチtiffのページごとに用紙サイズ 潤x（たまりん） ページの最後に飛ぶ

[[20230711085454]]　『Excel VBA マルチtiffのページごとに用紙サイズ潤x（たまりん）　ページの最後に飛ぶ