VBAでJPGサイズ変更

質問

VBAで
1.JPGファイルを読み込み
2.読み込んだJPGファイルの画像サイズ変更
3.再度JPG出力

の処理を行いたいのですが、どなたか分かる方がいますでしょうか？
サンプルコード、関連サイトなど教えていただけると幸いです。

お時間のある方、是非教えてください。

回答No.3

mitarashi · ベストアンサー

某掲示板でshiraさんという方から教わったコードをアレンジさせていただきました。宣言部は別途投稿します。
Sub test()
Dim src As String,dst As String

src="c:\s.jpg"
dst="c:\d.jpg"
If Dir(dst) <> "" Then Kill (dst)
Call resizePicture(src,dst,20,7,70)
End Sub

Function resizePicture(ByVal srcPath As String,_
ByVal dstPath As String,_
Optional ByVal scalerate As Long=100,_
Optional ByVal InterpolationMode As InterpolationMode=InterpolationModeHighQualityBicubic,_
Optional ByVal jpegQuality As Long=85)
Dim IID_IDispatch As GUID
Dim pd As PICTDESC
Dim udtInputAs GdiplusStartupInput
Dim lngTokenAs Long,lngStatus As Long
Dim pGraphics As Long
Dim pSrcBmp As Long,pDstBmp As Long
Dim lngWidthAs Long,lngHeight As Long
Dim EncodParameters As EncoderParameters

udtInput.GdiplusVersion=1
If GdiplusStartup(lngToken,udtInput,ByVal 0&)<>0 Then
Exit Function
End If

If GdipCreateBitmapFromFile(ByVal StrPtr(srcPath),pSrcBmp)<>0 Then
GdiplusShutdown lngToken
Exit Function
End If

GdipGetImageWidth pSrcBmp,lngWidth
GdipGetImageHeight pSrcBmp,lngHeight
lngWidth=lngWidth * scalerate \ 100
lngHeight=lngHeight * scalerate \ 100

If GdipGetImageGraphicsContext(pSrcBmp,pGraphics)=0 Then
lngStatus=GdipCreateBitmapFromGraphics(lngWidth,lngHeight,pGraphics,pDstBmp)
GdipDeleteGraphics pGraphics
If lngStatus=0 Then
If GdipGetImageGraphicsContext(pDstBmp,pGraphics)=0 Then
GdipSetInterpolationMode pGraphics,InterpolationMode
GdipDrawImageRectI pGraphics,pSrcBmp,0,0,lngWidth,lngHeight
GdipDeleteGraphics pGraphics
EncodParameters.Count=1
With EncodParameters.Parameter(0)
.GUID=ConvCLSID(CLSID_Quality)
.NumberOfValues=1
.Type=4
.Value=VarPtr(jpegQuality)
End With
Call GdipSaveImageToFile(pDstBmp,StrPtr(dstPath),ConvCLSID(CLSID_JPEG),VarPtr(EncodParameters))
End If
GdipDisposeImage pDstBmp
End If
End If
GdipDisposeImage pSrcBmp
GdiplusShutdown lngToken
End Function

Private Function ConvCLSID(ByVal sGuid As String) As GUID
CLSIDFromString StrPtr(sGuid),ConvCLSID
End Function

回答No.6

mitarashi

#3です。前から気になっていたのですが、ようやく原因がわかりました。
リサイズの補間モードが、
InterpolationModeHighQualityBicubic
だと、左端と、上端に灰色の線が出来てしまいます。白基調の画像だと気になると思います。
InterpolationModeBicubic (=4)
等を選択するか、事前に白で塗りつぶしておく様にしてください。
GdipSetInterpolationMode pGraphics, InterpolationMode
'-------　これを追加 dim hBrush as long を宣言要
GdipCreateSolidFill &HFFFFFFFF, hBrush
GdipFillRectangle pGraphics, hBrush, 0, 0, lngWidth, lngHeight
GdipDeleteBrush hBrush
'-------　ここまで
GdipDrawImageRectI pGraphics, pImageTemp, 0, 0, lngWidthd, lngHeightd

回答No.5

tom11

＃2です

簡単に出来るかと思ったら、かなり、面倒でした。

VBAのオブジェクトブラウザでは、ないコマンドが
オートマクロで、達成されていたり、

vbaのヘルプを見たら、
画像フォーマットを変えられそうだったのですが。
それも出来なかったみたいでです。

でも、jpegの画像ファイルを、1/5のサイズに変換するのが
実に、単純な、コードで終わりました。
でも、保存された画像は、jpegになるかどうかは、
結果を見てみないと解らないみたいです。

Public Sub f()

ActiveSheet.Pictures.Insert("filepath.JPG").Select

Selection.ShapeRange.Width = Selection.ShapeRange.Width / 5#
Selection.ShapeRange.Height = Selection.ShapeRange.Height / 5#

ActiveWorkbook.SaveAs Filename:= "Book1.htm",FileFormat:=xlHtml, ReadOnlyRecommended:=False, CreateBackup:=False

End Sub

単純な、動作なので、自分でオートマクロで作ってみたら、
確実なコードが、得られると思います。
簡便方としては、良いのでは、ないですか？？

回答No.4

mitarashi

#3の続きというか、こちらの方が前なのですが。GDI+の関数名は長いので、2K文字に納めるのに疲れました。不足する関数・定数は
http://okwave.jp/qa/q5124395.html
のKenKen_SPさんのご回答をご参照下さい。
Public Enum GDIPlusStatusConstants
Ok = 0
'(略）
End Enum
Public Enum InterpolationMode
'(略)
InterpolationModeBilinear = 3
InterpolationModeBicubic = 4
InterpolationModeNearestNeighbor = 5
InterpolationModeHighQualityBilinear = 6
InterpolationModeHighQualityBicubic = 7
End Enum
Type PICTDESC
cbSizeofstruct As Long
picType As Long
hbitmap As Long
hpal As Long
unused_wmf_yExt As Long
End Type
Declare Function GdipGetImageGraphicsContext Lib "gdiplus" _
(ByVal image As Long, graphics As Long) As Long
Declare Function GdipDeleteGraphics Lib "gdiplus" _
(ByVal graphics As Long) As Long
Declare Function GdipSetInterpolationMode Lib "gdiplus" _
(ByVal graphics As Long, _
ByVal nInterpolationMode As InterpolationMode) As Long
Declare Function GdipGetImageWidth Lib "gdiplus" _
(ByVal image As Long, Width As Long) As Long
Declare Function GdipGetImageHeight Lib "gdiplus" _
(ByVal image As Long, Height As Long) As Long
Declare Function GdipDrawImageRectI Lib "gdiplus" _
(ByVal graphics As Long, ByVal image As Long, _
ByVal X As Long, ByVal Y As Long, _
ByVal Width As Long, ByVal Height As Long) As Long
Declare Function GdipCreateBitmapFromFile Lib "gdiplus" _
(fileName As Any, bitmap As Long) As Long
Declare Function GdipCreateBitmapFromGraphics Lib "gdiplus" _
(ByVal Width As Long, ByVal Height As Long, _
ByVal target As Long, bitmap As Long) As Long

Const CLSID_JPEG = "{557CF401-1A04-11D3-9A73-0000F81EF32E}"
Const CLSID_Quality = "{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"

お礼

mitarashiさん
ご丁寧にコードの記述ありがとうございます。

内容確認しながら試してみます。

ほんとにありがとうございます。

回答No.2

tom11

検索したら、面白い方法が、

jpegの画像を、sheetに貼り付けて、
画像サイズを調整して、web保存、、、
ホームページになりますが。
画像は、イメージファイルになり、web保存時に
vbaで、容易に、jpegにできそうです。

一連の動作を、vbaにすれば、
image.jpegのファイル名で、ファイルサイズを
調整できそうです。

お礼

ご回答ありがとうございます。

自分でも書けそうなレベルなので
検討してみます！！

回答No.1

DIooggooID

http://okwave.jp/qa/q2409531.html

補足

ご回答ありがとうございます。

明熊JPEG保存DLL

は自分もネットで見つけましたが
自分のＰＣ以外でも作業する場合があるので
他の方法を探していました。

質問には書いておりませんでした。
ご回答くださったのにすみません。。。

ありがとうございました。