Excel マクロ 写真挿入

質問

こんにちは Excel2003で使っていた写真を挿入するマクロで困っています。
2003では問題なく画像が挿入され配布先でも見れましたが、2010では写真の保存先（リンク）を貼ったことになり、自分のPCでは問題ないくても送付先で見ることが出来ません。
どこをどのように変更すれば宜しいでしょうか？よろしくお願い致します。

Sub 画像をまとめてサイズ指定挿入改()
Dim a As Range
Dim bb As Integer

Dim cc As Range
Dim W As Single
Dim H As Single
Dim mx As Long
Dim fi As Long
Dim i As Long
Dim pkfile

On Error GoTo extLine

With Application
bb = .InputBox("貼り付ける画像の枚数を入力してください。 　　　　　 ※最大１０枚までです。", Type:=2)

Select Case bb
Case "1"
Set a = Range("A1")
Case "2"
Set a = Range("A1,H1")
Case "3"
Set a = Range("A1,H1,a22")
Case "4"
Set a = Range("A1,H1,a22,h22")
Case "5"
Set a = Range("A1,H1,a22,H22,A43")
Case "6"
Set a = Range("A1,H1,a22,H22,A43,H43")
Case "7"
Set a = Range("A1,H1,a22,H22,A43,H43,A64")
Case "8"
Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64")
Case "9"
Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85")
Case "10"
Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85,H85")
Case Else
MsgBox "枚数は1～10の数字で入力してください"
GoTo extLine
End Select

pkfile = .GetOpenFilename("すべての図" & _
"(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
"*.jpe;*.png;*.bmp;*.gif)," & _
"*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
"*.jpe;*.png;*.bmp;*.gif", 2, _
"挿入する図の選択（複数選択可）", , True)
If Not IsArray(pkfile) Then
MsgBox "ファイルが指定されていません", , _
"複数画像の一括挿入"
GoTo extLine
End If
W = 320
H = 240
.ScreenUpdating = False
End With

mx = UBound(pkfile)
fi = 1
For Each cc In a
If cc.Address = cc.MergeArea.Item(1).Address Then
Call picIns(cc, pkfile(fi), W, H)
fi = fi + 1
If fi > mx Then
Set cc = Nothing
Exit For
End If
End If
Next

For i = fi To mx
Set a = a(a.Rows.Count, 1).Offset(1)
Call picIns(a, pkfile(i), W, H)
Next
extLine:
Set a = Nothing
Application.ScreenUpdating = False
With Err()
If .Number <> 0 Then MsgBox .Number & ":" & .Description
End With
End Sub

Sub picIns(ByVal r As Range, _
ByVal s As String, _
ByVal W As Single, _
ByVal H As Single)

With ActiveSheet.Pictures.Insert(s).ShapeRange
If (W > 0) And (H > 0) Then
.LockAspectRatio = msoFalse
.Width = W
.Height = H
ElseIf W > 0 Then
.Width = W
ElseIf H > 0 Then
.Height = H
End If
.Left = r.Left
.Top = r.Top
End With
End Sub

Private Sub CommandButton1_Click()
画像をまとめてサイズ指定挿入改
End Sub

回答No.1

eden3616 · ベストアンサー

2010からVBAの仕様が変わり、2007まで組み込みで張り付けれた方法ですと
リンク貼り付けになるようになりました。
該当部分を修正すれば対応できます。

下から二つ目のグループの
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
　　略
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
Sub picIns(ByVal r As Range, _
ByVal s As String, _
ByVal W As Single, _
ByVal H As Single)

★ここから★
With ActiveSheet.Pictures.Insert(s).ShapeRange　
If (W > 0) And (H > 0) Then
.LockAspectRatio = msoFalse
.Width = W
.Height = H
ElseIf W > 0 Then
.Width = W
ElseIf H > 0 Then
.Height = H
End If
.Left = r.Left
.Top = r.Top
End With
★ここまで★
End Sub
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
　　略
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
上記★ここから★　から　★ここまで★を削除して

ActiveSheet.Shapes.AddPicture(s, False, True, r.Left, r.Top, W, H).Apply

を削除した場所に追加してください。

最終的に以下のようになればいいです。
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
　　略
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
Sub picIns(ByVal r As Range, _
ByVal s As String, _
ByVal W As Single, _
ByVal H As Single)
ActiveSheet.Shapes.AddPicture(s, False, True, r.Left, r.Top, W, H).Apply
End Sub
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
　　略
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～

お礼

早速の回答ありがとうございます。
無事に解決いたしました。また、プラスアルファのアドバイスまで頂きとても助かりました。
また機会があればよろしくお願い致します。
誠にありがとうございました。

回答No.4

eden3616

度重なり申し訳ありません。

No3において
※以下は初期の状態からの変更点になります
は間違いです。

■No1のみ行っていただければ

・2010でも画像が埋め込まれます

■No1とNo2のみ行っていただければ

・2010でも画像が埋め込まれます
・画像の上限が10個以上にも対応します

■No1とNo3のみ行っていただければ

・2010でも画像が埋め込まれます
・画像の上限が10個以上にも対応します
・挿入する画像の枚数入力が不要になります

回答の連続投稿によりややこしくしてしまい申し訳ありませんでした。

回答No.3

eden3616

度重なる回答失礼します。
No2の回答において以下の１行は無くても良いです。（あっても問題ありません）
Debug.Print i & ",座標( "; 1 + 22 * Int((i - 0.5) / 2) & " , " & 1 + 7 * ((i - 1) Mod 2) & ")"

No1だけでも2010で動作できると思いますが最終的に以下のようにされますと、
・2010で画像を埋め込み
・10枚以上の画像に対応
・張り付ける画像の枚数を毎回入力する必要がない
状態になると思います。

※以下は初期の状態からの変更点になります

～～～～～～～～～～～～～～～～～～～～
With Application
bb = .InputBox("貼り付ける画像の枚数を入力してください。 　　　　　 ※最大１０枚までです。", Type:=2)

Select Case bb
Case "1"
Set a = Range("A1")
Case "2"
～～～～～～～～～～
　中　略
～～～～～～～～～～
MsgBox "ファイルが指定されていません", , _
"複数画像の一括挿入"
GoTo extLine
End If
W = 320
H = 240
.ScreenUpdating = False
End With
～～～～～～～～～～～～～～～～～～～～

の部分を

～～～～～～～～～～～～～～～～～～～～
With Application

pkfile = .GetOpenFilename("すべての図" & _
"(*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
"*.jpe;*.png;*.bmp;*.gif)," & _
"*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;" & _
"*.jpe;*.png;*.bmp;*.gif", 2, _
"挿入する図の選択（複数選択可）", , True)
If Not IsArray(pkfile) Then
MsgBox "ファイルが指定されていません", , _
"複数画像の一括挿入"
GoTo extLine
End If
W = 320
H = 240
.ScreenUpdating = False
End With

bb = UBound(pkfile)
Set a = Range("A1")
For i = 2 To bb
Set a = Union(a, Cells(1 + 22 * Int((i - 0.5) / 2), 1 + 7 * ((i - 1) Mod 2)))
Next i
～～～～～～～～～～～～～～～～～～～～

に変更してください。

回答No.2

eden3616

ちなみに余談ですが
～～～～～～～～～～～～～～～～
Select Case bb
Case "1"
Set a = Range("A1")
Case "2"
Set a = Range("A1,H1")
Case "3"
Set a = Range("A1,H1,a22")
Case "4"
Set a = Range("A1,H1,a22,h22")
Case "5"
Set a = Range("A1,H1,a22,H22,A43")
Case "6"
Set a = Range("A1,H1,a22,H22,A43,H43")
Case "7"
Set a = Range("A1,H1,a22,H22,A43,H43,A64")
Case "8"
Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64")
Case "9"
Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85")
Case "10"
Set a = Range("A1,H1,a22,H22,A43,H43,A64,H64,A85,H85")
Case Else
MsgBox "枚数は1～10の数字で入力してください"
GoTo extLine
End Select
～～～～～～～～～～～～～～～～
上記部分を
～～～～～～～～～～～～～～～～
Set a = Range("A1")
For i = 2 To bb
Debug.Print i & ",座標( "; 1 + 22 * Int((i - 0.5) / 2) & " , " & 1 + 7 * ((i - 1) Mod 2) & ")"
Set a = Union(a, Cells(1 + 22 * Int((i - 0.5) / 2), 1 + 7 * ((i - 1) Mod 2)))
Next i
～～～～～～～～～～～～～～～～

のように置き換えると最大10枚という上限も解除できます。
（11枚以上の画像の貼付も対応できそうです）

ダイアログの表示も変更されるのであれば、
bb = .InputBox("貼り付ける画像の枚数を入力してください。 　　　　　 ※最大１０枚までです。", Type:=2)
を
bb = .InputBox("貼り付ける画像の枚数を入力してください。", Type:=2)
としてください。