VB6 指定したセルの画像のサイズ変更

質問

お世話になります

すでにエクセルに画像が複数張り付けられている状態で、
指定したセルに存在している画像のサイズのみ変更したいのですが、
皆目見当がつきません。
色々調べると、新規に張り付けた時の処理は見つかるのですが、
今回の様に、すでに存在していて、かつ、一括ではない場合のサンプルを見つけられませんでした。

判っている条件は以下となります
１．画像はＪｐｅｇ形式で張り付いています
２．サイズは全て異なります
３．張り付いているセルの位置は全て判っています
　　　⇒　Ｃｅｌｌｓ（５，１０）　Ｃｅｌｌｓ（１０、１０）・・・・・
４．画像はセルより大きく、複数のセルにまたがって張り付いております
５．サイズ変更はアスペクト比を保ったまま変更
６．画像の重なりはございません

ActiveSheet.Cells(YY1, XX1).Selectまでは何となく理解できております

回答No.1

h_tana_0530 · ベストアンサー

こんばんは。

ご要望のプログラミングのポイントは２つあると思います。
1)レンジ・オブジェクトから画像オブジェクトは参照できないので、レンジ（セル）から直接画像を指定することはできないです。
画像オブジェクトのセル・プロパティを１つずつ調べて、指定のセルに存在するかどうか、探索しなければなりません。
2)サイズの変更は、shapeオブジェクトのScaleHeight（高さ）,ScaleWidth（幅） メソッドを使います。
両方を同じ倍率で変更すれば、縦横比を保ってサイズを変えられます。

下にプログラム例を記述します。
画像のあるセルと、倍率を引数で指定して呼び出すサブプロシージャです。
引数 rg は、画像の存在する左上のセルのレンジを指定します。
引数 z は変更する倍率を倍精度数で指定します。
”Worksheets("****")”　のアスタリスク部は、検索するシート名に変更してください。

（すみませんが、急いで作ったためプログラムの動作確認はできておりません。ご自分で確認をお願いします。）
お試しくださいマセ。

Sub PictureZoom(rg as Range,z as Double)

Dim shp as Shape
Dim nme as String

For Each shp In Worksheets("****").Shapes

'指定セル上の画像を探す
If shp.TopLeftSell.Address = rg.Address then
nme = shp.Name
Exit For
End If
Next

'サイズ変更
Set shp=Worksheets("****").Shapes(nme)
shp.ScaleHeight z, msoFalse
shp.ScaleWidth z, msoFalse

set shp=Nothing

End Sub

お礼

お礼が遅れてすみませんでした。
教えていただいた内容をもとに改良して、無事作成することが出来ました
アドバイスありがとうございました。