Excel VBAによるコピー作業について

質問

お世話になります。初心者ですが、掲題の件、以下の通り質問させて下さい。

【環境】
★イメージ列の各セルにほぼ収まる状態でイメージが貼りつけられた以下のExcelシートがあります。

※項番:一部飛んでいます。
※イメージ:一部張り付いていないセルがあります。

=================================
項番 ｜イメージ
=================================
1 ｜ ABC
---------------------------------
2 ｜ Ａ＠
---------------------------------
3 ｜
---------------------------------
4 ｜ Ｂ＊
---------------------------------
7 ｜ CBA
---------------------------------
8 ｜ HHH
---------------------------------
10 ｜ YYY
---------------------------------
11 ｜
---------------------------------
12 ｜ AAA
---------------------------------
15 ｜ BBB
=================================

【VBAでの実行タスク】
★上記Excel（仮称:test.xlsx）ファイル上の全イメージを個別に名前を付けて保存したい。
（001.jpeg,002.jpeg,003.jpeg,004.jpeg,007.jpeg,008.jpeg,010.jpeg,011.jpeg,012.jpeg,015.jpeg）

※保存先はローカルの適当な場所（例:C:\Users\test\Pictures）

【作成中のVBA】
---
Sub 画像保存()

Dim sSavePath As String
Dim gdipRet As GDIPlusStatusConstants
Dim myStdPicture As StdPicture

ActiveSheet.Shapes.Range(Array("Picture 1")).Select
Application.Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

Set myStdPicture = CreatePictureFromClipboard

'jpg保存するときはこの下の行を有効に(100ところを0～100に変更でクオリティ設定できる)
gdipRet = SavePictureJpg(myStdPicture, "C:\Users\test\Pictures\001.jpg", 100)

End Sub
---

【質問内容】
上記VBAですと、実行することで、001.jpgしか保存されない状況です。
1回のVBA実行で、1,2,3,4,7,8,10,11,12,15全てのイメージを個別に名前を付けて保存するには、
（001.jpeg,002.jpeg,003.jpeg,004.jpeg,007.jpeg,008.jpeg,010.jpeg,011.jpeg,012.jpeg,015.jpeg）
VBAの記述をどう修正すべきかご教示頂きたく存じます。

何卒、宜しくお願い申し上げます。

回答No.1

cj_mover · ベストアンサー

こんにちは。

CreatePictureFromClipboard() 関数
SavePictureJpg() 関数
については、そちらの環境で正しく動作するものが設定されているとして、
それらの関数については、当方の環境では再現できませんので、こちらは一切関知しません。

ご質問のポイントは、
対象のイメージと項番をすべて捉えてループすること、
対象のイメージと項番との対応関係を正しく得ること、
保存するファイル名を正しく整形すること
の３点、と考えました。

厄介なのは、
> ★イメージ列の各セルにほぼ収まる状態でイメージが貼りつけられた以下のExcelシートがあります。
の、"ほぼ収まる状態"、という部分です。
例えば項番4に対応したイメージが、項番3に掛かるような位置にあっても、
項番4と関連付けする方法として、
　イメージの中心点のＹ座標（縦方向位置）と、
　イメージが貼り付けられたセル（.TopLeftCell）のひとつ下のセルの.Top
とを比較して
　.TopLeftCell の行のＡ列の項番と関連付けるか
　.TopLeftCell のひとつ下のセルの行のＡ列の項番と関連付けるか
を決めます。
中心点が収まっていない状態なら、
ひとつ下のセルに"ほぼ収まる状態"であろう、という解釈です。

sSavePath を事前に "C:\Users\test\Pictures\" と設定。
ActiveSheet の .Shapes を総当たりでループして、
　各Shape（oShape）の
　　.Type が, msoPicture であるならば、
　　　.TopLeftCell.Column が、１～２列め、であるならば、
　　　　中心点とセルのＹ座標を比較することで分岐して、
　　　　　対応する項番を、nSrNum に格納
///
　　　　以降の処理は、ご提示のまま、
　　　　ファイル名については sSavePath & Format$(nSrNum, "000") & ".jpg"
　　　　Format$() 関数で項番を３桁に整形します。
///

ActiveSheet の .Shapes を総当たりする中で、
.Type プロパティが, msoPicture を返す場合だけに限定していますが、
修正が必要ならば、ＶＢＥのオブジェクトブラウザで、MsoShapeType を確認の上、
応用してください。

' ' ///
Sub 画像保存()

　　Dim sSavePath As String
　　Dim gdipRet As GDIPlusStatusConstants
　　Dim myStdPicture As StdPicture
　　Dim oShape As Shape
　　Dim nSrNum As Long

　　sSavePath = "C:\Users\test\Pictures\"

　　With ActiveSheet
　　　　For Each oShape In .Shapes
　　　　　　With oShape
　　　　　　　　If .Type = msoPicture Then
　　　　　　　　　　If .TopLeftCell.Column < 3 Then
　　　　　　　　　　　　If .Top + .Height / 2 < .TopLeftCell.Offset(1).Top Then
　　　　　　　　　　　　　　nSrNum = .TopLeftCell.EntireRow.Cells(1).Value
　　　　　　　　　　　　Else
　　　　　　　　　　　　　　nSrNum = .TopLeftCell.Offset(1).EntireRow.Cells(1).Value
　　　　　　　　　　　　End If

　　　　　　　　　　　　.CopyPicture Appearance:=xlScreen, Format:=xlBitmap

　　　　　　　　　　　　Set myStdPicture = CreatePictureFromClipboard

　　　　　　　　　　　　'jpg保存するときはこの下の行を有効に(100ところを0～100に変更でクオリティ設定できる)
　　　　　　　　　　　　gdipRet = SavePictureJpg(myStdPicture, sSavePath & Format$(nSrNum, "000") & ".jpg", 100)

　　　　　　　　　　End If
　　　　　　　　End If
　　　　　　End With
　　　　Next
　　End With

End Sub
' ' ///

お礼

以下関数での保存が利かなくなりました。所々修正してみます。
・CreatePictureFromClipboard() 関数
・SavePictureJpg() 関数

ご教示いただきまして、ありがとうございました。