[[20240410132556]]　『トリミング（切り出し）part3』（joy）　ページの最後に飛ぶ

『トリミング（切り出し）part3』（joy）

やりたい事が増加したので追加で
　違った画像の切り抜きがしたいのでコードを書いてみました。

参考画像の赤色枠の(0,1/4y) - (X,3/4y)の部分を抜き出したい。
https://imgur.com/kmP5n1h

以下のコードで　実行エラーがでます。
　「余白が無効です。マイナスまたは空のイメージの寸法を指定してください」
　
　　Set Img = IP.Apply(Img) 'apply change

どう修正すれば良いですか　？

　Sub part3()

      Dim InputFile As String
      Dim OutputFile As String

      InputFile = "D:\text.jpg"
      OutputFile = "D\test(1).jpg"

      Dim Img As Object 'As ImageFile
      Dim IP 'As ImageProcess

      Set Img = CreateObject("WIA.ImageFile")
      Set IP = CreateObject("WIA.ImageProcess")

      'ターゲット画像の読み込み
      Img.LoadFile InputFile

      ' 元の画像の幅と高さを取得
      Dim imageWidth As Integer
      Dim imageHeight As Integer

      imageWidth = Img.width
      imageHeight = Img.height

      ' 切り取りたい範囲を指定
      Dim left As Integer
      Dim top As Integer
      Dim right As Integer
      Dim bottom As Integer

      left = imageWidth * 0      '
      top = imageHeight * 0.25   '1/4*y
      right = imageWidth         'x
      bottom = imageHeight * 0.75 '3/4*y

      ModImage InputFile, OutputFile, left, top, right, bottom

　End Sub

      Sub ModImage(inFile As String, outFile As String, left As Integer, top As Integer, right As Integer, bottom As Integer)

            Dim Img As Object, IP As Object

            Set IP = CreateObject("WIA.ImageProcess") 'create WIA objects
            Set Img = CreateObject("WIA.ImageFile")

            Img.LoadFile inFile 'load image
            IP.Filters.Add IP.FilterInfos("Crop").FilterID 'setup filter

            With IP.Filters(1)
                  .Properties("Left") = left
                  .Properties("Top") = top
                  .Properties("Right") = right
                  .Properties("Bottom") = bottom
            End With

            Set Img = IP.Apply(Img) 'apply change

            Img.SaveFile outFile 'save image

      End Sub

＜使用 Excel：Excel2021、使用 OS：Windows11 ＞

 Cropの各Propertiesに設定する数値は「余白」の方の幅だと思います。(画像の幅じゃなくて)
[[20240408122016]]でもそういう解釈でコード書きましたけど。

  つまりは↓こういう事なのでは?　と予想。

 >      ModImage InputFile, OutputFile, left, top, right, bottom
                                                    ↓    ↓
        ModImage InputFile, OutputFile, left, top, left,  top

（白茶） 2024/04/10(水) 18:27:14

＞　Cropの各Propertiesに設定する数値は「余白」の方の幅だと思います。(画像の幅じゃなくて)
＞　[[20240408122016]]でもそういう解釈でコード書きましたけど。

ありがとうございます。
以下に変更して上手く処理できました。
ModImage InputFile, OutputFile, left, top, left, top

前回と今回を総合して考えると
コードは、パラメーターで必要なのはleftとtopでrightとbottomは必要ないのですね。
なのでコードは、下記で良いと言う事で試してみたら上手く処理できました。
（前回は、縦に３つに切り分けた場合で今回は横に３つに切り分けた場合ですが
どちらの場合でも同じコードで対応できそうですがどうでしょうか？）

Sub ModImage(inFile As String, outFile As String, left As Long, top As Long)

      Dim Img As Object, IP As Object

      Set IP = CreateObject("WIA.ImageProcess") 'create WIA objects
      Set Img = CreateObject("WIA.ImageFile")

      Img.LoadFile inFile 'load image
      IP.Filters.Add IP.FilterInfos("Crop").FilterID 'setup filter

      With IP.Filters(1)
            .Properties("Left") = left
            .Properties("Top") = top
      End With

      Set Img = IP.Apply(Img) 'apply change

      Img.SaveFile outFile 'save image

End Sub

これで何で余白部分が削除されて画像部分のみがトリミングできるのか？
まだ理解できていません。

参考になりそうな記事を探していますが探しきれていません。
（joy） 2024/04/10(水) 19:21:59

 おや? それだと上と左しか切り捨てられないのでは...?
 下と右は切らないで良かったんですかね?
                                   ...まあ狙い通りなんだったらいいですけど ^^;

 .Properties("Left") = 画像の左側の切り捨て幅
 .Properties("Top")  = 画像の上側の切り捨て幅

 切り捨て幅なのでマイナスは設定不可ですし、
 切り捨て幅が画像の幅を超えてしまうと、結果的に描画するものが無くなってしまい、
 Apply時に冒頭で提示されたエラーメッセージが返る事になります。

（白茶） 2024/04/10(水) 20:41:46

白茶さん、何度もありがとうございます。

＞＞おや? それだと上と左しか切り捨てられないのでは...?

失礼しました。
早合点してしまいました。
先のコードでは上分だけで下分が削除されていませんでした。
（作成された画像を成功例の方で見ていました。）

前回の縦に３つに切り分けた場合も今回のコードで統一すべく頑張っていますが
付け焼き刃ではうまく処理できていません。

残す画像を基準に削除する範囲をどのように指定するのかが全然理解できていません。
つまり、何を見て、左、上、右、下を指定するのかが理解できていません。
（コードのLeft,Top,Right,Bottom の領域が理解できていません。）

      With IP.Filters(1)
            .Properties("Left") = left        '画像の左側の切り捨て幅
            .Properties("Top") = top          '画像の上側の切り捨て幅
            .Properties("Right") = right      '画像の右側の切り捨て幅
            .Properties("Bottom") = bottom    '画像の下側の切り捨て幅
      End With

前回の例と同じ縦に３つに切り分けた場合の添付画像でもう一度回答願えませんか？
X,Yの画像から真ん中にある画像を1辺がYの正方形に切り出す場合です。

添付画像
https://imgur.com/3f2FkLh
（joy） 2024/04/11(木) 09:25:41

 例えばXが500、Yが300だとしたら、
 カットする幅は合計200(Abs(X-Y))なので、
 左と右をそれぞれ100(200の半分)ずつカットすれば良い訳ですから...

    Const X = 500!, Y = 300!

    Dim lr As Long, tb As Long
    If X > Y Then lr = (X - Y) \ 2
    If Y > X Then tb = (Y - X) \ 2

    Debug.Print X; Y, "=>"; lr; tb, "=>"; X - lr - lr; Y - tb - tb

    With IP.Filters(1)
        .Properties("Left") = lr      '画像の左側の切り捨て幅
        .Properties("Top") = tb       '画像の上側の切り捨て幅
        .Properties("Right") = lr     '画像の右側の切り捨て幅
        .Properties("Bottom") = tb    '画像の下側の切り捨て幅
    End With

 という感じになろうかと思います。

（白茶） 2024/04/11(木) 10:08:48

ありがとうございます。

以下で上手く処理できました。

      left = lr
      top = tb
      right = lr
      bottom = tb

 やっと図を書きながら理解できました。

 残す画像から見て（左、上、右、下）方向では
 　　縦割りなら「上」と「下」は無いので　topとbottom　はゼロ
 　　横割りなら「左」と「右」は無いので　leftとright　　はゼロ
と考えるのですね。
（joy） 2024/04/11(木) 12:00:13

画像の分割後に画像の整形を追加したいので
マクロを追加しました。

以下のコードでエラーがでます。
　　Set Img = IP.Apply(Img) 'apply change

　　実行エラー　：　適用するフィルターがありません。
　　　　　　　　「追加」を使用して、適用サれるフィルターコレクションにフィルターを追加します。

　　フィルターの追加はどうすれば良いですか　？

Option Explicit
Sub part3() '四面分割

      Dim InputFile As String
      Dim OutputFile As String

      InputFile = "D:\text.jpg"
      OutputFile = "D\test(1).jpg"

      Dim Img As Object 'As ImageFile
      Dim IP 'As ImageProcess

      Set Img = CreateObject("WIA.ImageFile")
      Set IP = CreateObject("WIA.ImageProcess")

      'ターゲット画像の読み込み
      Img.LoadFile InputFile

      ' 元の画像の幅と高さを取得
      Dim imageWidth As Long
      Dim imageHeight As Long

      imageWidth = Img.width
      imageHeight = Img.height

      ' 切り取りたい範囲を指定
      Dim left As Long
      Dim top As Long
      Dim right As Long
      Dim bottom As Long

      left = 0.2 * imageWidth
      top = 0.15 * imageHeight
      right = 0.2 * imageWidth
      bottom = 0.15 * imageHeight

      ModImage InputFile, OutputFile, left, top, right, bottom

      '---------------

      '  再整形

      'ターゲット画像の読み込み
      Img.LoadFile OutputFile

      imageWidth = Img.width
      imageHeight = Img.height

      Dim NewWidth As Long
      Dim NewHeight As Long

      ' 新しい画像サイズ
      NewWidth = (Img.height + Img.width) / 2
      NewHeight = (Img.height + Img.width) / 2

      ' 画像サイズを指定して新規に画像を作成
      With CreateObject("WIA.ImageProcess")
            .Filters.Add .FilterInfos("Scale").FilterID
            .Filters(1).Properties("MaximumWidth") = NewWidth
            .Filters(1).Properties("MaximumHeight") = NewHeight
            .Filters(1).Properties("PreserveAspectRatio") = False      'false : アスペクト比は維持しない
      End With

      Set Img = IP.Apply(Img) 'apply change

      Kill OutputFile
      Img.SaveFile OutputFile 'save image

End Sub
Function ModImage(inFile As String, outFile As String, left As Long, top As Long, right As Long, bottom As Long)

      Dim Img As Object, IP As Object

      Set IP = CreateObject("WIA.ImageProcess") 'create WIA objects
      Set Img = CreateObject("WIA.ImageFile")

      Img.LoadFile inFile 'load image
      IP.Filters.Add IP.FilterInfos("Crop").FilterID 'setup filter

      With IP.Filters(1)
            .Properties("Left") = left        '画像の左側の切り捨て幅
            .Properties("Top") = top          '画像の上側の切り捨て幅
            .Properties("Right") = right      '画像の右側の切り捨て幅
            .Properties("Bottom") = bottom    '画像の下側の切り捨て幅
      End With

      Set Img = IP.Apply(Img) 'apply change

      Img.SaveFile outFile 'save image

End Function

（joy） 2024/04/11(木) 15:16:12

 コード読んだだけで動作確認まではしてないんですけど、
 変数[IP]に対してフィルタが追加されてない状態でのApplyになってます。

 >       Dim IP 'As ImageProcess
 >       Set IP = CreateObject("WIA.ImageProcess")

                からの↓これ　　(この間「IP.Filters.Add」が出てこない)

 >       Set Img = IP.Apply(Img) 'apply change

 あるいは、変数[IP]は使わずに、Withブロックの中で済ませてしまうか

 >       ' 画像サイズを指定して新規に画像を作成
 >       With CreateObject("WIA.ImageProcess")
 >             .Filters.Add .FilterInfos("Scale").FilterID
 >             .Filters(1).Properties("MaximumWidth") = NewWidth
 >             .Filters(1).Properties("MaximumHeight") = NewHeight
 >             .Filters(1).Properties("PreserveAspectRatio") = False      'false : アスペクト比は維持しない
 >             Set Img = .Apply(Img) 'apply change '★ココ
 >       End With

 そんな感じに見えます。

（白茶） 2024/04/11(木) 15:44:56

ありがとうございます。

アドバイスどうり追加（Apply)していなかったのが原因でした。

コードを修正して上手く処理できました。

お陰様で
ばらばらで今まで作成したコードを一箇所にまとめる作業に入れます。
（joy） 2024/04/11(木) 17:27:00

コメント返信：

[ 一覧(最新更新順) ]

[[20240410132556]] 『トリミング（切り出し）part3』（joy） ページの最後に飛ぶ

[[20240410132556]]　『トリミング（切り出し）part3』（joy）　ページの最後に飛ぶ