『指定フォルダー内のファイル(JPEG）のサイズを正方形に変換して同名で保存』（Muse）
ExcelのVBAで指定フォルダー内のファイル(JPEG）のサイズ（横1ｘ縦1）を正方形に変換して同名で保存したい。
正方形のサイズとは、(横1+縦1)/2と縦と横が同じサイズのことです。
（変更時にアスペクト比を維持する必要はありません。）
以下を試して見ましたが変化がありません。
（コードは、ネットを参考にしました。）
Option Explicit
Sub RESIZETEST()
Dim folderPath As String
Dim fileName As String
Dim filePath As String
Dim newWidth As Long
Dim newHeight As Long
' 変換するフォルダーのパスを指定
folderPath = "C:\Users\mido\"
' フォルダー内のJPEGファイルを処理
fileName = Dir(folderPath & "*.jpg")
While fileName <> ""
filePath = folderPath & fileName
' 画像のサイズを取得
Dim oImageFile As Object
Set oImageFile = CreateObject("WIA.ImageFile")
oImageFile.LoadFile filePath
' 正方形のサイズを計算
newWidth = (oImageFile.Width + oImageFile.Height) \ 2
newHeight = newWidth
' 画像を正方形にリサイズして保存
Call WIA_ResizeImage(filePath, filePath, newWidth, newHeight, True, True)
fileName = Dir()
Wend
End Sub
Public Function WIA_ResizeImage(ByVal sInitialImage As String, _
ByVal sResizedImage As String, _
ByVal lMaximumWidth As Long, _
ByVal lMaximumHeight As Long, _
Optional ByVal bPreserveAspectRatio As Boolean = False, _
Optional ByVal bOverwrite As Boolean = False) As Boolean
End Function
＜ 使用 Excel：Excel2021、使用 OS：Windows11 ＞
ちょっと勘違いした回答を書いてしまったので、消しました。 すみません （´・ω・`） 2024/03/30(土) 12:24:19
こちらの手法も手詰まりです。
Sub ResizeJPEGFilesToSquare()
Dim FolderPath As String
Dim FileName As String
Dim NewWidth As Double
Dim NewHeight As Double
Dim OriginalWidth As Double
Dim OriginalHeight As Double
Dim AspectRatio As Double
Dim NewFilePath As String
Dim OriginalFilePath As String
Dim FileSystem As Object
Dim FileObject As Object
' 指定フォルダーのパス
FolderPath = "C:\Users\mido\"
' FileSystemオブジェクトを作成
'VBEのツールから参照設定で、Microsoft Scripting Runtimeにチェックを入れてください。
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' 指定フォルダー内のファイルを処理
For Each FileObject In FileSystem.GetFolder(FolderPath).Files
If LCase(FileSystem.GetExtensionName(FileObject.Path)) = "jpg" Then
' オリジナルファイルのパス
OriginalFilePath = FileObject.Path
' 新しいファイル名（同名+_Squareで保存）
NewFilePath = FolderPath & FileSystem.GetBaseName(OriginalFilePath) & "_Square.jpg"
' オリジナル画像のサイズを取得
With CreateObject("WIA.ImageFile")
.LoadFile OriginalFilePath
OriginalWidth = .Width
OriginalHeight = .Height
End With
' 正方形のサイズを計算
AspectRatio = (OriginalWidth + OriginalHeight) / 2
NewWidth = AspectRatio
NewHeight = AspectRatio
' 画像を正方形にリサイズして保存
'使う前の準備として、先にVBAエディタからツール⇒参照設定
'⇒Microsoft Windows Image Acquisition Libraly 2.0 にチェック入れてください
With CreateObject("WIA.ImageProcess")
.Filters.Add .FilterInfos("Scale").FilterID
.Filters(1).Properties("MaximumWidth") = NewWidth
.Filters(1).Properties("MaximumHeight") = NewHeight
.Filters(1).Properties("PreserveAspectRatio") = False
.ApplyToFile OriginalFilePath, NewFilePath
End With
End If
Next FileObject
' メッセージボックスを表示
MsgBox "処理が完了しました。"
End Sub
（Muse） 2024/03/30(土) 16:14:38
マジレスすべきなのかどうなのか悩ましい... と思って傍観してました。^^;
> 以下を試して見ましたが変化がありません。 については、 ホントに Function WIA_ResizeImage の中身が無い状態で試してるんなら、 変化が無くて当然ですよね? (これで変化したらある意味ホラー...)
たぶん最低限↓これくらいは書かないと何もならないでしょう。
Public Function WIA_ResizeImage(ByVal sInitialImage As String, _
ByVal sResizedImage As String, _
ByVal lMaximumWidth As Long, _
ByVal lMaximumHeight As Long, _
Optional ByVal bPreserveAspectRatio As Boolean = False, _
Optional ByVal bOverwrite As Boolean = False) As Boolean
Dim oWIA As Object 'WIA.ImageFile
Dim oIP As Object 'ImageProcess
Set oWIA = CreateObject("WIA.ImageFile")
Set oIP = CreateObject("WIA.ImageProcess")
oIP.Filters.Add oIP.FilterInfos("Scale").FilterID
oIP.Filters(1).Properties("MaximumWidth") = lMaximumWidth
oIP.Filters(1).Properties("MaximumHeight") = lMaximumHeight
oIP.Filters(1).Properties("PreserveAspectRatio") = bPreserveAspectRatio
oWIA.LoadFile sInitialImage
Set oWIA = oIP.Apply(oWIA)
If bOverwrite Then
On Error Resume Next
Kill sResizedImage
On Error GoTo 0
End If
oWIA.SaveFile sResizedImage
WIA_ResizeImage = True
End Function
で、その上で、
> Call WIA_ResizeImage(filePath, filePath, newWidth, newHeight, True, True)
↑ココ
名前付き引数の名前から察するに、この場合「False」だと思います。
（白茶） 2024/03/30(土) 16:50:07
Function WIA_ResizeImageの中身が無いので何も処理しないでリターンしていたのですね。
ホラーだと言われて当然です。
Functionを変更してうまく処理できました。
（Call文のパラメーターもFALSEに書き換えました。）
（Muse） 2024/03/30(土) 17:54:26
「別のアプローチ」の方もちょっと見てみました。
Sub ResizeJPEGFilesToSquare()
Dim FolderPath As String
Dim FileName As String
Dim NewWidth As Double
Dim NewHeight As Double
Dim OriginalWidth As Double
Dim OriginalHeight As Double
Dim AspectRatio As Double
Dim NewFilePath As String
Dim OriginalFilePath As String
Dim FileSystem As Object
Dim FileObject As Object
Dim o As Object '◆追加
' 指定フォルダーのパス
FolderPath = "C:\Users\mido\"
' FileSystemオブジェクトを作成
'VBEのツールから参照設定で、Microsoft Scripting Runtimeにチェックを入れてください。
Set FileSystem = CreateObject("Scripting.FileSystemObject")
' 指定フォルダー内のファイルを処理
For Each FileObject In FileSystem.GetFolder(FolderPath).Files
If LCase(FileSystem.GetExtensionName(FileObject.Path)) = "jpg" Then
' オリジナルファイルのパス
OriginalFilePath = FileObject.Path
' 新しいファイル名（同名+_Squareで保存）
NewFilePath = FolderPath & FileSystem.GetBaseName(OriginalFilePath) & "_Square.jpg"
' オリジナル画像のサイズを取得
Set o = CreateObject("WIA.ImageFile") '◆追加
With o 'CreateObject("WIA.ImageFile") '■書替
.LoadFile OriginalFilePath
OriginalWidth = .Width
OriginalHeight = .Height
End With
' 正方形のサイズを計算
AspectRatio = (OriginalWidth + OriginalHeight) / 2
NewWidth = AspectRatio
NewHeight = AspectRatio
' 画像を正方形にリサイズして保存
'使う前の準備として、先にVBAエディタからツール⇒参照設定
'⇒Microsoft Windows Image Acquisition Libraly 2.0 にチェック入れてください
With CreateObject("WIA.ImageProcess")
.Filters.Add .FilterInfos("Scale").FilterID
.Filters(1).Properties("MaximumWidth") = NewWidth
.Filters(1).Properties("MaximumHeight") = NewHeight
.Filters(1).Properties("PreserveAspectRatio") = False
'.ApplyToFile OriginalFilePath, NewFilePath '■削除
.Apply(o).SaveFile NewFilePath '◆追加
End With
End If
Next FileObject
' メッセージボックスを表示
MsgBox "処理が完了しました。"
End Sub
（白茶） 2024/03/30(土) 17:56:01
ついでに。^^;
私自身「Windows Image Acquisition」ってのは全く存じ上げなかったモノで今回初めて使ってみました。 いい機会を与えて頂き勉強になりました。ありがとうございます。
でまぁお礼というか ここ最近「GDI+ フラット API」について手探り勉強中で、自分的にタイムリーなネタだったので、ちょっと別案書いてみました。 ネットのアチコチからコピってきてペッペして整えただけですけどね。ご笑納くださいwww
Option Explicit
#If False Then
Dim InterpolationMode
Const InterpolationModeInvalid = -1
Const InterpolationModeDefault = 0&
Const InterpolationModeLowQuality = 1&
Const InterpolationModeHighQuality = 2&
Const InterpolationModeBilinear = 3&
Const InterpolationModeBicubic = 4&
Const InterpolationModeNearestNeighbor = 5&
Const InterpolationModeHighQualityBilinear = 6&
Const InterpolationModeHighQualityBicubic = 7&
#End If
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As Long
SuppressExternalCodecs As Long
End Type
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (ByRef token As LongPtr, ByRef inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As LongPtr = 0) As Long
Private Declare PtrSafe Function GdiplusShutdown Lib "gdiplus" (ByVal token As LongPtr) As Long
Private Declare PtrSafe Function GdipLoadImageFromFile Lib "gdiplus" (ByVal FileName As LongPtr, ByRef image As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal image As LongPtr) As Long
Private Declare PtrSafe Function GdipGetImageHeight Lib "gdiplus" (ByVal image As LongPtr, ByRef Height As Long) As Long
Private Declare PtrSafe Function GdipGetImageWidth Lib "gdiplus" (ByVal image As LongPtr, ByRef Width As Long) As Long
Private Declare PtrSafe Function GdipGetImageGraphicsContext Lib "gdiplus" (ByVal image As LongPtr, graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipDrawImageRectI Lib "gdiplus.dll" (ByVal GpGraphics As LongPtr, ByVal GpImage As LongPtr, ByVal Left As Long, ByVal Top As Long, ByVal Width As Long, ByVal Height As Long) As Long
Private Declare PtrSafe Function GdipDeleteGraphics Lib "gdiplus" (ByVal graphics As LongPtr) As Long
Private Declare PtrSafe Function GdipCreateBitmapFromGraphics Lib "gdiplus" (ByVal Width As Long, ByVal Height As Long, ByVal graphics As LongPtr, bitmap As LongPtr) As Long
Private Enum InterpolationMode 'イメージをスケーリングまたは回転するときに使用されるアルゴリズムを指定します
InterpolationModeInvalid = -1 '内部的に使用される
InterpolationModeDefault = 0& '既定の補間モードを指定します。
InterpolationModeLowQuality = 1& '低品質モードを指定します。
InterpolationModeHighQuality = 2& '高品質モードを指定します。
InterpolationModeBilinear = 3& '双一次補間を指定します。 事前フィルター処理は実行されません。このモードは、イメージを元のサイズの 50% 以下にするような縮小処理には適していません。
InterpolationModeBicubic = 4& '双三次補間を指定します。 事前フィルター処理は実行されません。このモードは、イメージを元のサイズの 25% 以下にするような縮小処理には適していません。
InterpolationModeNearestNeighbor = 5& '最近傍補間を指定します。
InterpolationModeHighQualityBilinear = 6& '高品質双一次補間を指定します。 事前フィルター処理が適用され、高品質の縮小処理が実行されます。
InterpolationModeHighQualityBicubic = 7& '高品質双三次補間を指定します。 事前フィルター処理が適用され、高品質の縮小処理が実行されます。 このモードを使用すると、変換後のイメージが高品質になります。
End Enum
Private Declare PtrSafe Function GdipSetInterpolationMode Lib "gdiplus" (ByVal graphics As LongPtr, ByVal nInterpolationMode As InterpolationMode) As Long
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type EncoderParameter
GUID As GUID
NumberOfValues As Long
TypeAPI As Long
Value As LongPtr
End Type
Private Type EncoderParameters
Count As Long
Parameter(0 To 15) As EncoderParameter
End Type
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal lpsz As Any, ByRef pCLSID As GUID) As Long
Private Const CLSID_BMP As String = "{557CF400-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_GIF As String = "{557CF402-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_TIF As String = "{557CF405-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_PNG As String = "{557CF406-1A04-11D3-9A73-0000F81EF32E}"
Private Const CLSID_JPG As String = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Private Const QUALITY_PARAMS As String = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal image As LongPtr, ByVal FileName As LongPtr, ByRef clsidEncoder As GUID, encoderParams As Any) As Long
Private Sub SaveToFile(hImg As LongPtr, FileName As String, Optional ByVal jpgQuarity As Long = 85)
Dim fGUID As GUID, p As EncoderParameters
Select Case UCase$(CreateObject("Scripting.FilesystemObject").GetExtensionName(FileName))
Case "JPG"
Call CLSIDFromString(StrPtr(CLSID_JPG), fGUID)
If jpgQuarity > 100 Then jpgQuarity = 100
If jpgQuarity < 1 Then jpgQuarity = 85
p.Count = 1
With p.Parameter(0)
Call CLSIDFromString(StrPtr(QUALITY_PARAMS), .GUID)
.TypeAPI = 4
.NumberOfValues = 1
.Value = VarPtr(jpgQuarity)
End With
Case "TIF": Call CLSIDFromString(StrPtr(CLSID_TIF), fGUID)
Case "GIF": Call CLSIDFromString(StrPtr(CLSID_GIF), fGUID)
Case "BMP": Call CLSIDFromString(StrPtr(CLSID_BMP), fGUID)
Case Else: Call CLSIDFromString(StrPtr(CLSID_PNG), fGUID)
End Select
If p.Count Then
Call GdipSaveImageToFile(hImg, StrPtr(FileName), fGUID, p)
Else
Call GdipSaveImageToFile(hImg, StrPtr(FileName), fGUID, ByVal 0&)
End If
End Sub
Private Function NumberedFilename(FileName As String, Optional Prefix As String, Optional Suffix As String) As String
Dim i As Long, p As String, b As String, e As String, fn As String
With CreateObject("Scripting.FilesystemObject")
p = .GetParentFolderName(FileName)
b = Prefix & .GetBaseName(FileName) & Suffix
e = .GetExtensionName(FileName)
fn = b & "." & e
i = 1
Do
NumberedFilename = .BuildPath(p, fn)
If Not .FileExists(NumberedFilename) Then Exit Do
i = i + 1
fn = b & Format$(i, " (0).") & e
Loop
End With
End Function
Private Function CreateResizedImage(hSrc As LongPtr, sizeW As Long, sizeH As Long) As LongPtr
Dim w As Long, h As Long, rtn As Long, hGrap As LongPtr, hRes As LongPtr
rtn = GdipGetImageWidth(hSrc, w)
rtn = GdipGetImageHeight(hSrc, h)
If w * h = 0 Then Exit Function
rtn = GdipGetImageGraphicsContext(hSrc, hGrap)
If rtn = 0 Then rtn = GdipCreateBitmapFromGraphics(sizeW, sizeH, hGrap, hRes)
If rtn = 0 Then rtn = GdipDeleteGraphics(hGrap)
If rtn = 0 Then rtn = GdipGetImageGraphicsContext(hRes, hGrap)
If rtn = 0 Then rtn = GdipSetInterpolationMode(hGrap, InterpolationModeBicubic)
If rtn = 0 Then rtn = GdipDrawImageRectI(hGrap, hSrc, 0, 0, sizeW, sizeH)
If rtn = 0 Then CreateResizedImage = hRes
If rtn = 0 Then rtn = GdipDeleteGraphics(hGrap)
End Function
Rem ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------
Sub RESIZETEST2()
Dim FolderPath As String
Dim FileName As String
Dim filePath As String
Dim NewWidth As Long
Dim NewHeight As Long
Dim tkn As LongPtr, gi As GdiplusStartupInput
Dim hImg As LongPtr, hResized As LongPtr
gi.GdiplusVersion = 1&
Call GdiplusStartup(tkn, gi)
FolderPath = "C:\Users\mido\"
FileName = Dir(FolderPath & "*.jpg")
While FileName <> ""
filePath = FolderPath & FileName
If GdipLoadImageFromFile(StrPtr(filePath), hImg) = 0 Then
Call GdipGetImageWidth(hImg, NewWidth)
Call GdipGetImageHeight(hImg, NewHeight)
NewWidth = (NewWidth + NewHeight) \ 2
hResized = CreateResizedImage(hImg, NewWidth, NewWidth)
If hResized Then
Call SaveToFile(hResized, NumberedFilename(filePath, , "_Square"))
Call GdipDisposeImage(hResized)
End If
Call GdipDisposeImage(hImg)
End If
FileName = Dir()
Wend
Call GdiplusShutdown(tkn)
End Sub
（白茶） 2024/03/30(土) 18:27:10
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.