『画像で中心部分以外の左右の部分が同じ単色かを判断』（すすむ）
現在、excelのVBAで指定ホルダー内の複数画像ファイル（ｊｐｇ）のサイズを変更して
同じ指定フォルダーに同名で全て保存しています。
縦サイズは変えずに横サイズのみを変えるが
横サイズは、アスペクト比を無視して縦サイズと同じサイズとするので
保存する画像は正方形（縦サイズX縦サイズ）となります。
横サイズの切り取り位置は、横サイズの中心部分を切り出すようなイメージです。
（つまり、元の横サイズの中心位置から左右に縦サイズの半分ずつは振り分ける）
ここまでのコードは作成できました。
相談は内容は、
上記の場合、「切り出される中心部分以外の左右の部分は、黒などの単色になるはず」なのですが
左右に単色部分が無い特異例も出てきました。
特異例の場合は、画像ファイルはアスペクト比を無視して
（縦サイズ＋横サイズ）/2を1辺とする正方形にサイズ変更したいのですが
切り出される「中心部分以外の左右の部分」が、黒などの同じ単色かをチェックするコードが必要となりました。
人間の目で観察して「中心部分以外の左右の部分」が同じ単色かは判断できますが
EXCEL（VBA）で判断させる事は出来ますか？
参考画像
https://imgur.com/kjNON9x
PC環境
Excel2024,Windows11
＜ 使用 Excel：Microsoft365、使用 OS：Windows11 ＞
出来なくはないみたいですけど WinApi を駆使することになりそぉです
とて〜もむつかしい。。。かも。 ← わたしにとってはですが
頑張ってみて下さい。
トリミングで切り出すと色は変わってあたりまえでは
変形させるだけなら。。。図はいびつに成りますが、両端の色は[画像は]変わらないのでは？
わたしでしたら 描画ソフトで作り直すかも(*^^*)
さらに、有識者様のご回答をお待ちくださいませ。。。。m(__)m
（隠居Z） 2025/04/20(日) 08:09:33
書き込み内容が理解できていません。
＞トリミングで切り出すと色は変わってあたりまえでは
１）（縦サイズ＋横サイズ）/2を1辺とする正方形トリミング
２）（縦サイズX縦サイズ）でトリミング
上記の２つの切り出すとどこの色が変わるのでしょうか？
１）では図はいびつに成りますが色は変わらないと思います
２）では、真ん中だけ残すイメージなので色は変わらないと思います
（両端部の単一色の部分は削除されるので判定外）
（すすむ） 2025/04/20(日) 09:22:09
------------------ - - - ***** - - * * - - ***** - - - - - ----------------- １． 上の - 画像が縦縞で7等分に7色に塗りつぶされている と仮定いたしますと * のサイズでトリミング「切り出すと」 上下左右の色は変わる箇所が有るという意味です。^^; ２． 縦横のサイズを変更するだけでしたら拡大縮小だけで画像そのものは残ると思います 結果見た目はいびつに成るかと。。。← 思います。。。。あれ まちがっていますぅ (￣▽￣；) m(__)mm(__)mm(__)m
（隠居Z） 2025/04/20(日) 10:51:00
ユーザーフォームで画像を表示させて目で見て判断できるように改良しました。
こちらこそお騒がせしてすいません。
（すすむ） 2025/04/21(月) 05:50:58
終わってるっぽいですが、ちょっとだけ。^^;
[[20250220121917]] 『図形の余白を減らすには?』（サラマンダー）
で私が晒してる遊び道具の中でちょっと似た事をやってますんで、ひょっとしたら参考になるかも...? と思て
・GetBitsでビットマップの各ビットを配列に取り込んでます。 ・TrimTransparentPixelsで「透明ではないピクセルの出現位置」を周囲４辺について検索し、 イメージの周囲にある透明ピクセル帯をカットした配列を作成します。 ・CreateFromBitsでビット配列からビットマップを生成します。
「透明ではないピクセル」の代わりに「黒ではないピクセル」を探せば...
あーでもなぁ...ジェイペグだもんなぁ...
お示しの参考画像の「Synthesizer Greatest Vol2」の左右の黒帯もおそらく「単色」ではないと思います。 上記の遊び道具で測ってみたら、0から&H0F0F0Fくらい幅で色の範囲がありました。 (まぁスクショっぽいんで、そちらのオリジナル画像とはまた違うのかも知れませんけど)
色に幅があると、画像によっては意匠と黒帯の境界が適切に判断できない可能性も出てきますからね。 黒の「しきい値」をどう決めるのか、という問題になります。
結局今の「目で見て判断」はどこかで必要になってくるのかなと。そう思いました。
（白茶） 2025/04/21(月) 17:31:48
膨大なコードを読み解くスキルは、私には無く
「目で見て判断」が現実的だと思います。
一応、下記コードで対応していますがアドバイスあればお願いします。
Option Explicit
'必要なUserForm（名前: frmCheck）
' ・Imageコントロール（画像表示用）
' ・「正方形に修正」ボタン（コマンドボタン）
' ・「縦サイズに合わせる（両端削除）」ボタン（コマンドボタン）
Public userResponse As VbMsgBoxResult ' UserFormの応答結果を保持
Sub 画像_縦サイズで正方形_2()
' 必要な参照設定:
' 1. Microsoft Scripting Runtime
' 2. Microsoft Windows Image Acquisition Library v2.0
Dim folderPath As String
Dim BackFolder As String
Dim fileName As String
Dim fso As Scripting.FileSystemObject
Dim folder As Scripting.folder
Dim file As Scripting.file
Dim img As ImageFile
Dim proc As ImageProcess
Dim origW As Long, origH As Long
Dim cropLeft As Long
Dim baseName As String, ext As String, newPath As String
' 画像フォルダのパスを指定
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "画像フォルダを選択してください"
If .Show = -1 Then
folderPath = .SelectedItems(1)
Else
MsgBox "フォルダが選択されませんでした。処理を中止します。"
Exit Sub
End If
End With
Set fso = New Scripting.FileSystemObject
Set folder = fso.GetFolder(folderPath)
' コピー先のフォルダー
BackFolder = folder & "\back\"
' コピー先フォルダー（back）が存在しない場合は作成
If Not fso.FolderExists(BackFolder) Then
fso.CreateFolder BackFolder
End If
Dim fileExt As String
' フォルダー内の全ファイルを走査
For Each file In folder.Files
fileExt = LCase(fso.GetExtensionName(file.Name))
' 拡張子がjpgまたはjpegのファイルのみコピー
If fileExt = "jpg" Or fileExt = "jpeg" Then
fso.CopyFile Source:=file.Path, Destination:=BackFolder & "\" & file.Name, OverWriteFiles:=True
End If
Next file
MsgBox "ターゲット.jpgを「back」フォルダーにコピーしました！", vbInformation
Dim tempPath As String
Dim OriginalFilename As String
For Each file In folder.Files
ext = LCase(fso.GetExtensionName(file.Name))
If ext = "jpg" Then
Set img = New ImageFile
img.LoadFile file.Path
origW = img.Width
origH = img.Height
If origW > origH Then
' 画像をユーザーに表示して確認
Load frmCheck
frmCheck.Image1.Picture = LoadPicture(file.Path)
frmCheck.Caption = "判定: " & file.Name
frmCheck.Show vbModal
If userResponse = vbYes Then
' 特異例処理: (縦+横)/2でリサイズ
Dim newSize As Long
newSize = (origW + origH) \ 2
Set proc = New ImageProcess
proc.Filters.Add proc.FilterInfos("Scale").FilterID
proc.Filters(1).Properties("MaximumWidth").Value = newSize
proc.Filters(1).Properties("MaximumHeight").Value = newSize
Set img = proc.Apply(img)
Else
' 通常処理: 中央切り出し
cropLeft = (origW - origH) \ 2
Set proc = New ImageProcess
proc.Filters.Add proc.FilterInfos("Crop").FilterID
proc.Filters(1).Properties("Left").Value = cropLeft
proc.Filters(1).Properties("Top").Value = 0
proc.Filters(1).Properties("Right").Value = origW - cropLeft - origH
proc.Filters(1).Properties("Bottom").Value = 0
Set img = proc.Apply(img)
End If
End If
' ' 新ファイル名を生成して保存の場合
' baseName = fso.GetBaseName(file.Name)
' newPath = folderPath & "\" & baseName & "_new." & ext
' img.SaveFile newPath
'
' 'オリジナルファイルを削除
' If Dir(file.Path) <> "" Then
' Kill file.Path ' 既存ファイルを削除
' End If
' 画像をオリジナルファイルに上書き保存する
img.SaveFile file.Path
End If
Next
MsgBox "処理が完了しました"
End Sub
（すすむ） 2025/04/21(月) 19:38:41
WIAですか。手軽に画像操作出来てイイっすよね。
私もWIAについては経験値低めなので、さほど詳しくはないんですけど、 確かImageFileからでもビット配列が取得出来たと思います。(↓こんな感じで)
If ext = "jpg" Then
Set img = New ImageFile
img.LoadFile file.Path
origW = img.Width
origH = img.Height
Rem *** ちょっと実験書き出し *********************
ReDim v(1 To origH, 1 To origW) As Long
With img.ARGBData
Dim i As Long, r As Long, c As Long
For r = 1 To origH
For c = 1 To origW
i = i + 1
v(r, c) = .Item(i)
Next
Next
End With
Cells(1, 1).Resize(origH, origW) = v
Rem ______________________________________________
If origW > origH Then
もし具体的な数値での判定を考えてみられるなら使えるかも知れません。 動きは遅いですけどね。１ビットずつ取り出しては配列に転記してますから。
普段は気にならないですけど「あぁ、VBAって遅いんだ...」が体感できます。^^;
（白茶） 2025/04/21(月) 21:40:49
ビット配列を使ってどうするかのアイデアが思い浮かばないので
せっかくのアドバイスを活かせそうに有りません。
先のコードでなにかアドバイがあればお願いしましたが
回答が付いて無いのでこのコードで問題ないと判断していいですか？
最初は、VBAでコメントアウトしているように
ファイルを別名(元ファイル名_new）で保存して元ファイルは消してました。
VBAが終了後に問題なれば別名で保存されたファイルを元ファイル名と同じに再度変名する
と言う作業を行っていましたが、コードが問題なさそうなので
再度の変名作業は無駄と判断して
'「 画像をオリジナルファイルに上書き保存する」コードに変更しました。
（すすむ） 2025/04/23(水) 17:05:27
>ビット配列を使ってどうするか 各ビット値を更にバイト単位(Red、Green、Blue)に分解すれば、 たとえば 端っこから1列ずつ検査してRed・Green・Blueどれかの平均値が 「しきい値」を超えたらそこからが意匠で、その手前までが黒帯部分。 とか、 そういう判定が計算で出来るかなぁ、と思ったのです。
まぁはい。ちょっとメンドイですかね。別に強くお勧めする事ではありません。^^;
> 問題ないと判断していいですか？ 思った通りの結果になっててエラーにもならないんなら、いいんじゃないでしょうか? とりあえず。 「back」フォルダにコピー取ってらっしゃるから、如何様にしても取り返しが付きますもんね。
（白茶） 2025/04/24(木) 23:45:06
＞そういう判定が計算で出来るかなぁ、と思ったのです。
回答いただいた内容は、理解できますが
それをコードに落とし込む作業を行うスキルは私にはなさそうなのと
提示したコードでも問題なさそうなので
今回の件はこれで解決としたいと思います
お世話になりました。
（すすむ） 2025/04/25(金) 07:56:03
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.