AddPictureで複数の画像を挿入したい

質問

エクセル2010で下のようなコードでPictures.InsertとFor文を使用して複数の画像を読み込んでます。
ところが、Pictures.Insertを2010で使用すると画像がリンク貼付されてしまうため、エクセル2003で画像を見ることができません。そこで、AddPictureを使用しなければならないということは理解したのですが、ネット上のサンプルコードは１つのファイルを読み込む場合のものばかりで、今まで通りに複数の画像を読み込むためのコードがなかなかみつかりません。しかしながら、会社にはVBAを操作できる人がおらず、ネットと本で独学していますが、どうしても、どこにFor文を入れたらよいのかわかりません。厚かましいのは承知ですが、下に現在使用しているコードをコピペしましたので、どこを直せばよいのか教えていただけますでしょうか・・・。
自分でやりきれる力があればよいのですが、会社にマクロを使える人がおらず、ネットと本を見ながらやっているのですが、これ以上自分で悩んでいる時間の余裕がありません。
なんとかお助けいただけますでしょうか。よろしくお願いいたします。
--
Sub 画像挿入()

Dim strFilter As String
Dim Filenames As Variant
Dim Pic As Picture

ActiveSheet.Range("K8").Select
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

Call BubbleSort_Str(Filenames, True, vbTextCompare)

Application.ScreenUpdating = False

For i = LBound(Filenames) To UBound(Filenames)
Set Pic = ActiveSheet.Pictures.Insert(Filenames(i))
With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMove
.PrintObject = True
End With
With Pic.ShapeRange
.LockAspectRatio = msoTrue
.Height = ActiveCell.MergeArea.Height
End With

ActiveCell.Offset(0, 7).Select
Set Pic = Nothing
Next i

Application.ScreenUpdating = True

End Sub

回答No.2

end-u · ベストアンサー

>Pictures.Insertを2010で使用すると画像がリンク貼付されてしまうため..
というのがポイントなのですよね。
『Excel 2010 で Pictures.Insert メソッドを使用して図をワークシートに挿入すると図がリンク オブジェクトとして挿入される』
http://support.microsoft.com/kb/2396509/ja

提示されたコードはおそらく
http://okwave.jp/qa/q2300268.html?order=asc
こちらが元になったものなのでしょう。
Q&A掲示板でも時々見かけます。
ファイル名のSortも盛り込んであるためニーズが高く、利用している方も多いのでしょうね。

'-----------------------------------------------
Option Explicit

Sub 画像挿入()
　　Dim strFilter As String
　　Dim Filenames As Variant
　　Dim rng　　　 As Range　'貼り付け先セル用変数
　　Dim i　　　　 As Long

　　'「ファイルを開く」ダイアログでファイル名を取得
　　strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png)," _
　　　　　　　& "*.jpg;*.jpeg;*.gif;*.bmp;*.png"
　　Filenames = Application.GetOpenFilename( _
　　　　　　　　FileFilter:=strFilter, _
　　　　　　　　Title:="図の挿入(複数選択可）", _
　　　　　　　　MultiSelect:=True)
　　'IsArray関数で判定し、キャンセルの場合はExit
　　If Not IsArray(Filenames) Then Exit Sub
　　' ファイル名をソート
　　Call BubbleSort_Str(Filenames, True, vbTextCompare)

　　'マクロ実行中の画面描写を停止
　　Application.ScreenUpdating = False
　　'貼り付け開始セルを変数にセット
　　Set rng = ActiveSheet.Range("K8")
　　'順番に画像を挿入
　　For i = LBound(Filenames) To UBound(Filenames)
　　　　'画像挿入Sub（貼り付けセル,画像ファイル名）
　　　　Call PictureIns(rng, Filenames(i))
　　　　'次の貼り付け先を変数にセット
　　　　Set rng = rng.Offset(0, 7)
　　Next i

　　Set rng = Nothing
　　Application.ScreenUpdating = True
End Sub
'-----------------------------------------------
' バブルソート（文字列）
Private Sub BubbleSort_Str( _
　　ByRef Source As Variant, _
　　Optional ByVal SortAsc As Boolean = True, _
　　Optional ByVal Compare As VbCompareMethod = vbTextCompare)

　　If Not IsArray(Source) Then Exit Sub

　　Dim i As Long, j As Long
　　Dim vntTmp As Variant
　　For i = LBound(Source) To UBound(Source) - 1
　　　　For j = LBound(Source) To LBound(Source) + UBound(Source) - i - 1
　　　　　　If StrComp(Source(IIf(SortAsc, j, j + 1)), _
　　　　　　　　　　　 Source(IIf(SortAsc, j + 1, j)), Compare) = 1 Then
　　　　　　　　vntTmp = Source(j)
　　　　　　　　Source(j) = Source(j + 1)
　　　　　　　　Source(j + 1) = vntTmp
　　　　　　End If
　　　　Next j
　　Next i
End Sub
'-----------------------------------------------
Private Sub PictureIns(ByRef r As Range, ByVal pName As String)
　　'AddPictureメソッドで元ファイルにLinkせず画像挿入
　　With r.Worksheet.Shapes.AddPicture(Filename:=pName, _
　　　　　　　　　　　　　　　　　　　 LinkToFile:=False, _
　　　　　　　　　　　　　　　　　　　 SaveWithDocument:=True, _
　　　　　　　　　　　　　　　　　　　 Left:=r.Left, Top:=r.Top, _
　　　　　　　　　　　　　　　　　　　 Width:=0, Height:=0)
　　　　'縦横比固定
　　　　.LockAspectRatio = msoTrue
　　　　'Height:=0で挿入したので元サイズに戻す
　　　　.ScaleHeight 1, msoTrue
　　　　'貼り付けセルの高さに合わせる
　　　　.Height = r.MergeArea.Height
　　End With
End Sub
'-----------------------------------------------

画像挿入の箇所をサブプロシージャにしてます。

お礼

実行したらうまくいきました！！！
ありがとうございます。本当に助かりました。
私の乱文から要旨をご指摘いただいた上、元コードの出典元を教えていただいた上、コードまで書いて頂き、本当に嬉しい限りです。
頂いたコードはじっくり見て勉強してみたいと思います。
本当にありがとうございました。

回答No.1

DreamyCat

これは複数ファイルを読み込むようになっています。
実行するたびに画面の右へ移動していくので見えないだけでしょう。
なお、ファイル名順に並べ替えをしているコードを呼び出している部分はコメントアウトしてあります。
シートのズーム倍率を５０％などにしておくと見えやすいかと思います。

Sub 画像挿入()

Dim strFilter As String
Dim Filenames As Variant
Dim Pic As Picture
Dim i As Long

ActiveSheet.Range("A8").Select
strFilter = "画像ファイル(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
Filenames = Application.GetOpenFilename( _
FileFilter:=strFilter, _
Title:="図の挿入(複数選択可）", _
MultiSelect:=True)
If Not IsArray(Filenames) Then Exit Sub

'Call BubbleSort_Str(Filenames, True, vbTextCompare)
Application.ScreenUpdating = False

For i = LBound(Filenames) To UBound(Filenames)
Set Pic = ActiveSheet.Pictures.Insert(Filenames(i))

With Pic
.Top = ActiveCell.Top
.Left = ActiveCell.Left
.Placement = xlMove
.PrintObject = True
End With

With Pic.ShapeRange
.LockAspectRatio = msoTrue
.Height = ActiveCell.MergeArea.Height
End With

ActiveCell.Offset(i, 7).Select
Set Pic = Nothing
Next i

Application.ScreenUpdating = True

End Sub

お礼

コメントありがとうございます。
上のコードを2010で実行してしまうと、画像がリンク貼り付けされるため、挿入貼付できるように書き換えたかったのです。要旨が明確でなかったので、うまくお伝えできなかったみたいです。せっかくコメント頂いたのにすみません。
困ってるときに、コメントがいただけたこと自体がとてもうれしかったです。ありがとうございました。