vbaで画像ファイルを開き、サイズを変更して保存

質問

vbaで画像ファイルを開き、その後サイズを変更して保存することは出来るのでしょうか？

ペイントで画像を開くのは

Sub test()
MyFileName = "C:\セット.jpg"
Shell "C:\WINDOWS\system32\mspaint.exe" & " " & Chr(34) & MyFileName & Chr(34), vbNormalFocus
End Sub

これで出来たのですが
その後、サイズ変更→ピクセル→
水平方向　300
垂直方向　225
を指定して保存したいのですが
そこまでVBAで可能でしょうか？

回答No.1

mitarashi · ベストアンサー

ペイントは使わない方法です。

１．Chartのエクスポート機能を利用する方法です。圧縮率は指定できません。（レジストリをいじれば可能かも）
下記コードでは、長辺を300にして、短辺は元画像の比率に合わせています。
Sub resizePicture()
Dim myWidth As Double, myHeight As Double
Dim picPath As String
Dim myPic As StdPicture
Dim myRatio As Double
Dim myChartObj As ChartObject
Const longSideLength As Double = 300

Application.ScreenUpdating = False
picPath = Application.GetOpenFilename("画像ファイル , *.*")
If picPath = "False" Then Exit Sub
Set myPic = LoadPicture(picPath)
myRatio = myPic.Width / myPic.Height
Set myPic = Nothing
If myRatio >= 1 Then
myWidth = longSideLength: myHeight = longSideLength / myRatio
Else
myWidth = longSideLength * myRatio: myHeight = longSideLength
End If
'Sheet(2)のところはアクティブでないシートを指定して下さい。
'作業用のChartObjectを生成して、用済み後は削除します。
Set myChartObj = Sheets(2).ChartObjects.Add(0, 0, myWidth, myHeight)
myChartObj.Chart.ChartArea.Fill.UserPicture PictureFile:=picPath
myChartObj.Chart.Export GetDesktopPath & "\" & "test.jpg"
myChartObj.Delete
Application.ScreenUpdating = True
End Sub
'動作確認のため便宜上デスクトップに保存している。
Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

２．圧縮率の指定できる、コードが長～い方法です。近頃のWindowsなら標準で備えているGDI+という機能を用いています。
http://okwave.jp/qa/q5647625.html

以上、ご参考まで。

お礼

ありがとうございます。