[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『サブフォルダー内の画像サイズを変換して保存』（Maputo）
現在以下の作業を一つ一つ手作業で処理しているので面倒くさく時間短縮の為
作業手順をVBAで処理できませんか ？
親ホルダー内にサブフォルダーが複数存在します。
各ホルダーの中には、必ず1個のJPEGが存在します。
（必ず１個で複数は存在しない）
そのJPEGを正方形の指定サイズ(500x500 ピクセル)にサイズ変換して元の各ホルダー内に別名で保存したい。
（元の変更前のJPEGは、そのまま残します。）
条件は、セルに指定
B2セルに、親フォルダー名（フルパス）例えば、D:\Music\Temp
B3セルに、正方形の変換サイズ指定 例えば、５００
＜ 使用 Excel：Excel2019、使用 OS：Windows10 ＞
そういうのはエクセルよりPowerShellでやったほうが楽。 わからないことはとりあず適当に書いた記事の部分をコピペしてググってから聞いて。
Win+Rでファイル名を指定して実行 cmdエンター powershellエンター Set-ExecutionPolicy RemoteSigned -Scope CurrentUserエンター 下のスクリプトをコピペしてエンター exitエンター exitエンター
[void][Reflection.Assembly]::LoadWithPartialName("System.Drawing")
#フォルダパスとフィルターは適当に指定
Get-ChildItem -LiteralPath 'F:\hoge_folder' -File -Filter "*.jpg"|
ForEach-Object{
$image=[System.Drawing.Bitmap]::new($_.FullName)
#サイズも変えたければ変える
$canvas = [System.Drawing.Bitmap]::new(500, 500)
$graphics = [System.Drawing.Graphics]::FromImage($canvas)
$graphics.DrawImage($image, [System.Drawing.Rectangle]::new(0, 0, $canvas.Width, $canvas.Height))
$_.DirectoryName+"\"+$_.BaseName+"_resize"+$_.Extension
$canvas.Save($_.DirectoryName+"\"+$_.BaseName+"_resize"+$_.Extension,[System.Drawing.Imaging.ImageFormat]::Jpeg)
}
（通りすがり） 2022/11/06(日) 16:59:43
（Maputo） 2022/11/06(日) 17:32:05
＞現在以下の作業を一つ一つ手作業で処理しているので面倒くさく Excelでどのように作業しているのか、手順を説明して下さい。 （γ） 2022/11/06(日) 19:34:31
＞Excelでどのように作業しているのか、手順を説明して下さい。
excelでは、処理していません。
ターゲットのJPEGを画像加工ソフトで画像サイズを変更する作業を
フォルダーをまたいで面倒でも続けています。
powershellでスクリプトからps1で保存して処理できました。
通りすがりさんありがとうございます。
（Maputo） 2022/11/07(月) 04:40:59
興味が無いので回答がないので有れば諦めます。
PowerShellでの回答をくれた「通りすがり」さん、
パスをフォルダーを選択するダイアログボックスを表示して
そこからから選択できるように改造願えればありがたいです。
（スクリプト内のパスを毎回書き換えて処理しているので手抜きをしたいです）
（Maputo） 2022/11/08(火) 11:43:28
＞試してみましたが、多層階のホルダー構造には対応していませんでした。
フォルダをドラッグ＆ドロップするとできます
（トォーリス・ガリ） 2022/11/08(火) 12:32:39
最初の質問で以下のように希望を伝えました。
「そのJPEGを正方形の指定サイズ(500x500 ピクセル)にサイズ変換して元の各ホルダー内に別名で保存したい。」
「縮小革命」は、縮小したjpgをオリジナルjpgがある元のホルダー内には保存していません。
その意味で「多層階のホルダー構造には対応していない」と回答しましたが
言葉足らずで気持ちが伝わらず失礼しました。
（Maputo） 2022/11/08(火) 12:49:01
上記サンプルの
> lngWidth = lngWidth * scalerate \ 100 > lngHeight = lngHeight * scalerate \ 100
↑この部分を無理矢理↓こうして
lngWidth = 500
lngHeight = 500
特に何も考えずに実行してみてもイケましたよ。 実際にはPtrSafeとかLongPtrとか、Declare部分の見直しは必要でしょうけど。 (私はExcel2010だしWIN64も関係ないのでそのままコピペで全く問題なかったス)
サブフォルダを再帰的に探索するコードは当掲示板でもちょくちょく見かけます。 (つい最近も数回あった気がする)
まぁGDI+は「EXCEL(VBA)での回答ではない」と言われればそうかも^^; 一応情報提供まで...
（白茶） 2022/11/08(火) 13:41:55
ここはエクセルの質問所なのでEXCEL(VBA)での回答を希望します。
この回答にはちょっとびっくりしたし、考えさせられた。
フォルダ選択にする技術も知っているし(ググれば見つかる)、すぐ出来るけど、
エクセルVBAじゃないし、VBAからpowershell呼び出せばセーフなのかとか、
白茶さんのGDI+同様。
なにか対価貰えればすぐやるけどこの掲示板ではだめなのかな。
白茶さんも情報提供してくれているし、意地悪なのかもしれないけどMaputoさんがこんな
コードを書いてみました、みたいな誠意みたいなものがあって「やる気を刺激されれば」書くかな。
でも優しい人が作ってくれるかもしれないね。
（通りすがり） 2022/11/08(火) 14:35:10
そうですね。
ファイラーを利用して縮小画像を含むフォルダーを一括して
元のフォルダーにコピペすれば良かったのですね。
頭が固くてそのアイデアは思いつきませんでした。
その手を使えばひと手間必要ですが問題なく処理できました。
（トォーリス・ガリ）さん、ありがとう。
白茶さんの貼ってくれたサイトのコードですが
初心者の私が活用できるレベルを超えています。
（少し、ちょちょっと修正（書き直し、追加）すれば良いようなレベルでは無いです。）
（通りすがり）さん、対価は与えられそうに無いので諦めます。
Posehershellは全くわからんぽんでスクリプトを書くなど手が付けられる知識は無いです。
(少し調べてスクリプトをps1で保存してpowershellから実行すればよさそう程度の知識を得たぐらいです。）
（Maputo） 2022/11/08(火) 16:22:11
（agt） 2022/11/08(火) 21:31:52
毎回作らなくとも、フォルダーのパスの部分を修正すればOKです。
「毎回新たに作れば。」が修正を含めているのであれば
すでに実行済みです。
＞フォルダ、----の選択-------------は
＞検索すればサンプルが見つかる
powershellについては門外漢である私でも
（通りすがり）さんのスクリプトを修正して
希望である
フォルダーのパスを選択するダイアログボックスを表示して
そこからから選択できるように相当する具体的な検索例を紹介して頂きたい。
＞ちょちょっと修正でいけると思います
powershellの実行は出来ています。
「ちょちょっと修正」、powershell初心者には簡単ではないです。
（Maputo） 2022/11/09(水) 04:12:20
（agt） 2022/11/09(水) 06:10:18
>ここはエクセルの質問所なのでEXCEL(VBA)での回答を希望します。
エクセルでも出来るってことだけで、エクセルでやろうってのが…。 なんかずれてると思う。 だってエクセルは画像編集ソフトじゃないし。
>面倒くさく時間短縮の為
これがすべてじゃないですかね 面倒くさいだけ。 答える帆も面倒くさいのでは。 （ずず） 2022/11/09(水) 08:32:50
>初心者の私が活用できるレベルを超えています ええ、わかってますよ。そんなの。
>少し、ちょちょっと修正（書き直し、追加）すれば良いようなレベルでは無いです ...だから、何だっていうのでしょう?
>ここはエクセルの質問所なのでEXCEL(VBA)での回答を希望します と「縛り」を設けたのはご自分でしょうに...
こちらにはどうでもいい事なので普段は気に掛けずに放置するんですけど、 よくある初心者を免罪符だと勘違いしている人ともなんかちょっと違う気がする。 ひょっとしておちょくられてるのかな?
（白茶） 2022/11/09(水) 09:08:27
（最後は、お叱りの回答が多いので嵐と思われても心外なのでこれが最後とします。）
（白茶さん）へ
私だけへの回答ではなく、書き込みはこのスレッドを見ている
他の方へのアドバイス的な回答だと言うのであれば賛同できますが、
初心者の私にレベルを超えた回答と判って書き込みされたのであれば残念です。
＞たぶん作った（作ってもらった）ものを納品しないといけないのでしょう
この書き込みについては、全く的はずれな内容です。
自分が使うのであって商売の為のモノではありません。
（Maputo） 2022/11/09(水) 11:12:15
いやまぁ、ホント別にいいんですけど... ^^;
何が残念なのかは全く理解できません。
せっかくタダで入手できた情報を、 まったく以って生かす気が無いその姿勢の方が余程残念だと思うんデスよね。
回答した側の心情としては「じゃあ訊くなよな」って感じです。
（白茶） 2022/11/09(水) 11:30:50
>達人さんはPowerShellの方が楽とはおっしゃいますが >powershellでスクリプトからps1で保存して処理できました。 と言っておきながら >初心者の私にレベルを超えた回答と判って書き込みされたのであれば残念です。 というのはおかしくないですか。 >Posehershellは全くわからんぽんでスクリプトを書くなど手が付けられる知識は無いです。 なのにどうして保存できたんでしょうかね。 嘘だったんですか。 （76s） 2022/11/09(水) 11:48:19
なぜか刺激を受けたので勉強がてらこんなバッチを作ってみました。
準備
1.以下の”””バッチスクリプト”””をメモ帳に貼り付け
2.名前を付けて保存で名前をresize.batにする
3.文字コードをANSIにする
4.デスクトップに保存する。
使い方
リサイズしたい画像の入った”””フォルダ”””を保存したバッチファイルにドラッグ＆ドロップ
以下バッチスクリプト、PowerShellじゃないですよ、バッチファイル、bat、拡張子がbatのやつ
::bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、batだよー間違えないでよー ::bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、batだよー間違えないでよー ::bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、bat、batだよー間違えないでよー
@cd /d %1
powershell -ExecutionPolicy RemoteSigned -Command^
[System.Reflection.Assembly]::LoadWithPartialName(\"System.Drawing\")^>$null;^
Write-Host `n`n;^
Get-ChildItem -LiteralPath ""%1"" -File -Filter \"*.jpg\" -Recurse ^|^
ForEach-Object{^
$image=[System.Drawing.Bitmap]::new($_.FullName);^
$canvas = [System.Drawing.Bitmap]::new(500, 500);^
$graphics = [System.Drawing.Graphics]::FromImage($canvas);^
$graphics.DrawImage($image, [System.Drawing.Rectangle]::new(0, 0, $canvas.Width, $canvas.Height));^
$_.DirectoryName+\"\\\"+$_.BaseName+\"_resize\"+$_.Extension;^
$canvas.Save($_.DirectoryName+\"\\\"+$_.BaseName+\"_resize\"+$_.Extension,[System.Drawing.Imaging.ImageFormat]::Jpeg);^
}
@powershell -noexit -nologo
（通りすがり） 2022/11/09(水) 13:03:16
もう見てないかもしれないですが・・・ 通りすがりさんに教えてもらったPowerShellの方法使って、ps1ファイルに書き込み、読込で実装してみました。 トリミングとスケーリングがあって、そこそこ悩みました・・・ VBAと構文違うと難しいですね。
Option Explicit
Enum ResizeOrder
SCALE_ONLY = 1
TRIM_ONLY = 2
SCALE_and_TRIM = 3
End Enum
Sub リサイズテスト()
Dim GET_USER_PARENT_DIRECTORY As String
Dim GET_USER_RENAME As String
Dim GET_USER_HEIGHT As Long
Dim GET_USER_WIDTH As Long
Dim mySETTING As ResizeOrder
Dim fNo As Integer
Dim i As Long
Dim psPath As String
'フォルダの選択
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = True Then
GET_USER_PARENT_DIRECTORY = .SelectedItems(1)
Else
MsgBox "フォルダが選択されませんでした"
Exit Sub
End If
End With
'末尾の名前
GET_USER_RENAME = "Resize"
'高さの設定
GET_USER_HEIGHT = 500
'幅の設定
GET_USER_WIDTH = 500
'出力設定
mySETTING = SCALE_and_TRIM
' mySETTING = SCALE_ONLY
' mySETTING = TRIM_ONLY
'https://qiita.com/miyamiya/items/d1a975fb6618d46eda0c
'文字コードはShiftJis（Open-PrintでShiftJis出力 メモ帳で作る場合、UTF-8注意）
'リサイズはトリミングではなく、伸縮
'PowerShell構文の配列列挙
Dim ps As String
Select Case mySETTING
Case ResizeOrder.SCALE_ONLY
'指定したサイズに合わせてスケーリング
ps = ps & " Get-ChildItem -LiteralPath 'USER_PARENT_DIRECTORY' -File -Filter ""*.jpg"" -Recurse -Depth 3|" & vbCrLf '指定したフォルダのサブディレクトリ「3層」までのjpgファイルを出力する
ps = ps & " ForEach-Object{" & vbCrLf
ps = ps & " $image=[System.Drawing.Bitmap]::new($_.FullName)" & vbCrLf '画像ファイル読込
ps = ps & " $canvas = [System.Drawing.Bitmap]::new(USER_WIDTH, USER_HEIGHT)" & vbCrLf '高さと幅の指定
ps = ps & " $graphics = [System.Drawing.Graphics]::FromImage($canvas)" & vbCrLf '縮小先への描画
ps = ps & " $graphics.DrawImage($image, [System.Drawing.Rectangle]::new(0, 0, $canvas.Width, $canvas.Height))" & vbCrLf '
ps = ps & " $_.DirectoryName+""\""+$_.BaseName+""_USER_RENAME""+$_.Extension" & vbCrLf
ps = ps & " $canvas.Save($_.DirectoryName+""\""+$_.BaseName+""_USER_RENAME""+$_.Extension,[System.Drawing.Imaging.ImageFormat]::Jpeg)" & vbCrLf '保存
ps = ps & " }" & vbCrLf
ps = ps & "Pause"
Case ResizeOrder.TRIM_ONLY
'指定したサイズに合わせて、左上を基準にトリミング
ps = ps & " Get-ChildItem -LiteralPath 'USER_PARENT_DIRECTORY' -File -Filter ""*.jpg"" -Recurse -Depth 3|" & vbCrLf
ps = ps & " ForEach-Object{" & vbCrLf
ps = ps & " $image=[System.Drawing.Bitmap]::new($_.FullName)" & vbCrLf
ps = ps & " $TrimRect = [System.Drawing.Rectangle]::new(0, 0, USER_HEIGHT, USER_WIDTH)" & vbCrLf
ps = ps & " $format = $image.PixelFormat" & vbCrLf
ps = ps & " $graphics = $image.Clone($TrimRect, $format)" & vbCrLf
ps = ps & " $_.DirectoryName+""\""+$_.BaseName+""_USER_RENAME""+$_.Extension" & vbCrLf
ps = ps & " $graphics.Save($_.DirectoryName+""\""+$_.BaseName+""_USER_RENAME""+$_.Extension,[System.Drawing.Imaging.ImageFormat]::Jpeg)" & vbCrLf '保存
ps = ps & " }" & vbCrLf
ps = ps & "Pause"
Case ResizeOrder.SCALE_and_TRIM
'指定したサイズの内、高さに合わせてスケーリングした後、左上を基準にトリミング
ps = ps & " Get-ChildItem -LiteralPath 'USER_PARENT_DIRECTORY' -File -Filter ""*.jpg"" -Recurse -Depth 3|" & vbCrLf
ps = ps & " ForEach-Object{" & vbCrLf
ps = ps & " $image=[System.Drawing.Bitmap]::new($_.FullName)" & vbCrLf
ps = ps & " [int]$ScaleWidth= (USER_HEIGHT / $image.Height)" & vbCrLf '<--最初にint型指定しないと、[System.Drawing.Bitmap]の引数指定でエラーが出る
ps = ps & " $ScaleWidth= (USER_HEIGHT / $image.Height)" & vbCrLf
ps = ps & " $ScaleWidth= ($image.Width * $ScaleWidth)" & vbCrLf
ps = ps & " $ScaleWidth= [math]::Truncate($ScaleWidth)" & vbCrLf
ps = ps & " $canvas = [System.Drawing.Bitmap]::new( $ScaleWidth , USER_HEIGHT)" & vbCrLf
ps = ps & " $graphics = [System.Drawing.Graphics]::FromImage($canvas)" & vbCrLf '縮小先への描画
ps = ps & " $graphics.DrawImage($image, [System.Drawing.Rectangle]::new(0, 0, $canvas.Width, $canvas.Height))" & vbCrLf '
ps = ps & " $TrimRect = [System.Drawing.Rectangle]::new(0, 0, USER_WIDTH, USER_HEIGHT)" & vbCrLf
ps = ps & " $format = $image.PixelFormat" & vbCrLf
ps = ps & " $ScaleTrim = $canvas.Clone($TrimRect, $format)" & vbCrLf
ps = ps & " $_.DirectoryName+""\""+$_.BaseName+""_USER_RENAME""+$_.Extension" & vbCrLf
ps = ps & " $ScaleTrim.Save($_.DirectoryName+""\""+$_.BaseName+""_USER_RENAME""+$_.Extension,[System.Drawing.Imaging.ImageFormat]::Jpeg)" & vbCrLf '保存
ps = ps & " }" & vbCrLf
ps = ps & "Pause"
End Select
'各種設定の落とし込み
ps = Replace(ps, "USER_PARENT_DIRECTORY", GET_USER_PARENT_DIRECTORY)
ps = Replace(ps, "USER_HEIGHT", GET_USER_HEIGHT)
ps = Replace(ps, "USER_WIDTH", GET_USER_WIDTH)
ps = Replace(ps, "USER_RENAME", GET_USER_RENAME)
'PS1ファイルの書き出し
psPath = ThisWorkbook.Path & "\resize.ps1"
fNo = FreeFile
Open psPath For Output As #fNo
Print #fNo, ps
Close #fNo
'PS1ファイルの実行
'https://excel-vba.work/2021/07/04/%E3%80%90vba%E3%80%91powershell%E3%83%95%E3%82%A1%E3%82%A4%E3%83%AB%E3%82%92%E5%90%8C%E6%9C%9F%E5%AE%9F%E8%A1%8C%E3%81%99%E3%82%8B/
With CreateObject("WScript.Shell")
.Run Command:="powershell -NoProfile -ExecutionPolicy Unrestricted " & psPath, WindowStyle:=1, WaitOnReturn:=True 'ウィンドウ表示 同期実行
'.Run Command:="powershell -NoProfile -ExecutionPolicy Unrestricted " & psPath, WindowStyle:=0, WaitOnReturn:=True 'ウィンドウ非表示 同期実行
End With
Kill psPath
MsgBox "完了しました"
End Sub
（稲葉） 2022/11/11(金) 13:24:28
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.