• ベストアンサー

VBAでJPGサイズ変更

VBAで 1.JPGファイルを読み込み 2.読み込んだJPGファイルの画像サイズ変更 3.再度JPG出力 の処理を行いたいのですが、どなたか分かる方がいますでしょうか? サンプルコード、関連サイトなど教えていただけると幸いです。 お時間のある方、是非教えてください。

質問者が選んだベストアンサー

  • ベストアンサー
  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.3

某掲示板で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

その他の回答 (5)

  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.6

#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

  • tom11
  • ベストアンサー率53% (134/251)
回答No.5

#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 単純な、動作なので、自分でオートマクロで作ってみたら、 確実なコードが、得られると思います。 簡便方としては、良いのでは、ないですか??

  • mitarashi
  • ベストアンサー率59% (574/965)
回答No.4

#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}"

tomcaptom
質問者

お礼

mitarashiさん ご丁寧にコードの記述ありがとうございます。 内容確認しながら試してみます。 ほんとにありがとうございます。

  • tom11
  • ベストアンサー率53% (134/251)
回答No.2

検索したら、面白い方法が、 jpegの画像を、sheetに貼り付けて、 画像サイズを調整して、web保存、、、 ホームページになりますが。 画像は、イメージファイルになり、web保存時に vbaで、容易に、jpegにできそうです。 一連の動作を、vbaにすれば、 image.jpegのファイル名で、ファイルサイズを 調整できそうです。

tomcaptom
質問者

お礼

ご回答ありがとうございます。 自分でも書けそうなレベルなので 検討してみます!!

  • DIooggooID
  • ベストアンサー率27% (1730/6405)
回答No.1
tomcaptom
質問者

補足

ご回答ありがとうございます。 明熊JPEG保存DLL は自分もネットで見つけましたが 自分のPC以外でも作業する場合があるので 他の方法を探していました。 質問には書いておりませんでした。 ご回答くださったのにすみません。。。 ありがとうございました。

関連するQ&A

  • エクセルVBAを使用してJPGファイルの名前を変更するには?

    MSエクセルのVBAを使用して、JPGファイル名を変更する方法はありますか? 具体的に言います。 約5,000個のJPGファイルにユニークな番号がにファイル名としてふられています。 このファイル名をすべて、頭3桁のゼロ埋めに変更したいのですが・・・ 例)50001.jpg ⇒ 00050001.jpg 50002.jpg ⇒ 00050002.jpg 50003.jpg ⇒ 00050003.jpg ・・・ このような処理は可能でしょうか? お願いします。

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

    vbaで画像ファイルを開き、その後サイズを変更して保存することは出来るのでしょうか? ペイントで画像を開くのは Sub test() MyFileName = "C:\セット.jpg" Shell "C:\WINDOWS\system32\mspaint.exe" & " " & Chr(34) & MyFileName & Chr(34), vbNormalFocus End Sub これで出来たのですが その後、サイズ変更→ピクセル→ 水平方向 300 垂直方向 225 を指定して保存したいのですが そこまでVBAで可能でしょうか?

  • jpgの画像のサイズ変更

    フオルダに有るjpgの画像を一括してサイズ変更したいのですが、フリーソウトを教えてください。

  • jpgの画像を画像サイズを変えずにファイルサイズを軽くしたい

    フォトショップを使用して、画像を加工しています。 背景は同一の物を使用して、(つまり全ての画像のサイズをそろえています)そこにいろいろな画像を一点づつペーストしています。 保存の際にJPGにしていますが、画像オプションの画質を変更して、 保存されるファイルサイズをほぼ同じ(20k~30kくらい)にそろえています。 しかし、中には色が多いものなど、画質だけではファイルサイズを小さくしきれないものが出てきました。 (最低画質にしても30kを超えてしまう) 画像の縦横サイズ(解像度)を変更しないで、ファイルサイズを軽くする方法はありませんか?

  • Jpg画像

    当ページで【サイズ、ピクセル数とかをどう理解すれば】(08/11/17)でご指導を頂きました。 ありがとうございました。 Photoshop画像で 画像解像度(ピクセル数、幅、高さの関連、そして解像度と印刷サイズの関連)は理解が深まり感謝しています。 当該Photoshop画像をjpg保存した場合について、 いま少しご指導願えれば幸いです。 jpg画像を見れば【大きさ3000×4509】【サイズ5.92MB】となっています。 (1)この数値の関連はどう理解すればよいのでしょうか。  Photoshop画像であれば  3000×4509×3(RGBの3原色)=40581000→概略40MB と理解 (2)なんだかトンチンカンな質問と恐縮しますが  jpg保存すればなにが変わるのでしょうか。  サイトを見れば難しきことが記載されていますが、  素人分かりする一言はあるのでしょうか。 (3)jpg画像には(これまたトンチンカンな質問ですが)  印刷時の幅、高さを決める【解像度】の概念はないのでしょうか。 (4)jpg画像をPhotoshopで開けた画像は  圧縮されていない元の画像と同じなんでしょうか。 要領をえない質問ばかりで申し訳ありません。 素人にはなんだか気になることばかりです。 ご教示願えれば幸いです。

  • jpg画像のファイルサイズを小さくしたい

    あまり色の数が多くないjpg画像をフリーソフトでgifに変換して見ましたらファイルサイズが大きくなります。 gif以外の種類の画像に変換しても全てファイルサイズが大きくなります。 画質を悪くしないでjpgファイルサイズを小さくする方法はないでしょうか?

  • 解像度を連続変更しつつリネームするバッチ処理

    例えば  サイズが1024X768の画像 sample58.jpg があったとして、それを 640X480に変更 sample58_l.jpg として別名保存 320X240に変更 sample58_m.jpg として別名保存 160X120に変更 sample58_s.jpg として別名保存 みたいなバッチ処理のできるソフトってありませんか? できればフリーソフトがいいです。

  • エクセルVBAによる複合機の設定について

    お世話になります。 会社の業務でPDF形式ファイルの図面出力を行なっています。出力機種は富士フイルム(旧富士ゼロックス)の複合機です。今エクセルのVBAを使い自動化を検討しているのですが(出力の前段階でとある処理をしており、それがVBAを使っているのでその絡みでVBAを使いたい)、A3サイズのZ折や二つ折りをしたくて色々と調べています。しかしなかなかその情報を見つけることができません。複合機への単純な出力は確認しているのですが、折などのオプション的な処理は果たして設定可能なのか、はたまた無理なのか全く掴めていません。どなたかそのような情報をお持ちな方がいらっしゃればご教授おり願いしたいと思っています。可能か不可能かだけでも構いませんが、可能なら例えばサンプルがあるサイトの情報もあれば嬉しいです。 よろしくお願いします。

  • jpg再圧縮でファイルサイズが増える?

    最近photoshopを触るようになりました。 写真を修整して、最高画質で別名保存した場合ファイルサイズが元ファイルより大きくなることがあります。 jpgを加工、再度jpgで保存するのですから、再圧縮によりファイルサイズは小さくなるのが普通だと思うのですが・・・ どういった理由でしょう?

  • ファイル名「1.jpg ~10.jpg~」のソート

    ただ今、エクセルのvbaを使って 複数の写真ファイルを一気に貼り付けてJPEGに変換するプログラムを作っています。 だいたいはできたのですが、一つ壁にぶつかりました。 アルゴリズムは指定したフォルダのファイル名を取得し、それをリスト用のシートに出力し、使用者に必要なファイルを取捨選択してもらうようにしています。 フォルダのファイル名は下記URLのサンプルから使わせていただいています。 http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_080.html しかし、これを使うと、 「1.jpg、2.jpg~10.jpg・・・」のファイル名を取得すると、 「1.jpg、10.jpg、2.jpg・・・」 という風になります。これを回避するには現状「01.jpg、02.jpg~10.jpg・・・」と名前をつけるしかないのですが、不特定多数の人に使わせるので、出来るだけ汎用性を持たせたいと思っています。 例えば 「テスト1-1.jpg、テスト1-2.jpg~テスト1-10.jpg・・・ テスト10-1.jpg、テスト10-2.jpg~テスト10-10.jpg・・・ テスト11-1.jpg、テスト11-2.jpg~テスト11-10.jpg・・・」 というファイル名を上の通りに並べ変えるとしたら、どうすればいいでしょうか? 難しい場合は 「01.jpg、02.jpg~10.jpg・・・」 の時だけでもいいのでよろしくお願いします。

専門家に質問してみよう