『トリミング(切り出し)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
ありがとうございます。
以下に変更して上手く処理できました。
ModImage InputFile, OutputFile, left, top, left, top
前回と今回を総合して考えると
コードは、パラメーターで必要なのはleftとtopでrightとbottomは必要ないのですね。
なのでコードは、下記で良いと言う事で試してみたら上手く処理できました。
(前回は、縦に3つに切り分けた場合で今回は横に3つに切り分けた場合ですが
どちらの場合でも同じコードで対応できそうですがどうでしょうか?)
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
>>おや? それだと上と左しか切り捨てられないのでは...?
失礼しました。
早合点してしまいました。
先のコードでは上分だけで下分が削除されていませんでした。
(作成された画像を成功例の方で見ていました。)
前回の縦に3つに切り分けた場合も今回のコードで統一すべく頑張っていますが
付け焼き刃ではうまく処理できていません。
残す画像を基準に削除する範囲をどのように指定するのかが全然理解できていません。
つまり、何を見て、左、上、右、下を指定するのかが理解できていません。
(コードのLeft,Top,Right,Bottom の領域が理解できていません。)
With IP.Filters(1) .Properties("Left") = left '画像の左側の切り捨て幅 .Properties("Top") = top '画像の上側の切り捨て幅 .Properties("Right") = right '画像の右側の切り捨て幅 .Properties("Bottom") = bottom '画像の下側の切り捨て幅 End With
前回の例と同じ縦に3つに切り分けた場合の添付画像でもう一度回答願えませんか?
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
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.