excelのマクロについて教えて下さい。（初心者です）

写真をセルに挿入するマクロをよく見ますが、以前から2003で使用していたマクロが2010で画像のリンク情報が挿入され、肝心の画像が挿入されていないためブックの配布が出来なくなりました。

ActiveSheet.Pictures.InsertメゾットをActiveSheet.Shapes.AddPictureに変更することで解決するような記述を目にしますが、エラーとなり間違いがよくわかりません。

ご伝授いただけないでしょうか。

セル内でマウスの右クリック、ホルダーを開いて画像を選択し挿入、セルの大きさに自動調整されセル内のセンターに収まるといったものです。

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim Pic As Picture

Application.ScreenUpdating = False

Cancel = True
On Error GoTo Err

If Target.MergeCells = False Then Exit Sub

Const MF1 As String = "JPEG Files (*.jpg;*.jpeg;*.jpe),*.jpg;*.jpeg;*.jpe"
Const MF2 As String = "ビットマップ (*.bmp),*.bmp"
Const MF3 As String = "GIF (*.gif),*.gif"
Const MF4 As String = "すべてのファイル (*.*),*.*"

Fname = Application.GetOpenFilename(FileFilter:=MF1 & "," & MF2 & _
"," & MF3 & "," & MF4)
If Fname = "False" Then
MsgBox "取り消されました。", vbInformation
Exit Sub
End If

For Each Pic In ActiveSheet.Pictures
If Pic.TopLeftCell.MergeArea.Address = Target.Address Then
Pic.Delete
End If
Next

Set Pic = Pictures.Insert(Fname)　　←　ここ
If Pic.Height > Pic.Width Then
GoTo PicH
ElseIf Pic.Height < Pic.Width Then
GoTo PicW
End If

PicH:
With Pic
.Top = Target.Top
.Left = Target.Left
.Placement = xlMove
End With
With Pic.ShapeRange
.LockAspectRatio = msoTrue
.Height = Target.Height
End With
If Pic.Width > Target.Width Then
GoTo PicW
Else
End If

GoTo Center

PicW:
With Pic
.Top = Target.Top
.Left = Target.Left
.Placement = xlMove
End With
With Pic.ShapeRange
.LockAspectRatio = msoTrue
.Width = Target.Width
End With
If Pic.Height > Target.Height Then
GoTo PicH
Else
End If

Center:
aw = Target.Width
bw = Pic.Width
x = (aw - bw) / 2
Pic.Left = Target.Left + x

ah = Target.Height
bh = Pic.Height
y = (ah - bh) / 2
Pic.Top = Target.Top + y

Set Fname = Nothing
Exit Sub

Err:
MsgBox "エラー番号:" & Err.Number
MsgBox "エラー内容：" & Err.Description

Application.ScreenUpdating = True

End Sub

No.1 回答者： WindFaller 回答日時： 2015/06/30 17:42

ご質問の内容をまとめると、

Excel 2010Pictures.Insertメソッドを使った方法では、画像のリンク情報だけを保存して、リンク先を表示しているだけで、元がないと、表示されなくなってしまう、という現象ですね。

ただ、このマクロは、オリジナルの縦横比を維持しようとして、そのどちらが、結合セルよりも大きい場合は縮小を、小さい場合は拡大をするという趣旨ではないかと思います。
ですから、Center に納まるという所については、今の所は、意味が分からないのです。

以下は、だいぶ、私のアレンジが入ってしまっています。
ただ、むしろ、リンクが切れたかどうか、調べてください。別のPCはあるものの、面倒極まりない作業の上に、こちらの時間が限られていますので、ご質問者側で、お願いしたいのです。

LinkToFile:=False　←ここ

※　参考にしたところ：
http://www.moug.net/tech/exvba/0120020.html

'//

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
　Dim FName As String
　Dim oShape As Shape
　Dim mPath As String, orgPath As String
　Dim mRng As Range
　Dim pic As Object
　Dim ht As Double
　Dim wd As Double
　orgPath = ThisWorkbook.Path
　Application.ScreenUpdating = False
　Cancel = True
　 On Error GoTo ErrHandler
　
　'画像がセル全面に入っていると、右クリックさえ出来ないので加えた
　For Each pic In Pictures
　　If TypeName(pic) = "Picture" Then
　　　If pic.TopLeftCell.MergeCells Then
　　　If MsgBox("画像を削除してよろしいですか？", vbQuestion + vbOKCancel) = vbCancel Then Exit Sub
　　　　pic.Delete
　　　　Set mRng = pic.TopLeftCell.MergeArea
　　　　'Targetセルは、結合セルではないので切り替える
　　　End If
　　End If
　Next pic
　
　If mRng Is Nothing Then
　　If Target.MergeCells = False Then
　　　Exit Sub
　　Else
　　　Set mRng = Target
　　End If
　Else
　　Set mRng = Target
　End If
　'ピクチャーフォルダーを探す
　mPath = CreateObject("Shell.Application").Namespace(&H27).Self.Path
　
　Const MF1 As String = "JPEG Files (*.jpg;*.jpeg;*.jpe),*.jpg;*.jpeg;*.jpe"
　Const MF2 As String = "ビットマップ (*.bmp),*.bmp"
　Const MF3 As String = "GIF (*.gif),*.gif"
　Const MF4 As String = "すべてのファイル (*.*),*.*"
　ChDir mPath
　FName = Application.GetOpenFilename(FileFilter:=MF1 & "," & MF2 & _
　"," & MF3 & "," & MF4)
　ChDir orgPath
　If FName = "False" Then
　　MsgBox "取り消されました。", vbInformation
　　Exit Sub
　End If
　
　With mRng
　　Set oShape = ActiveSheet.Shapes.AddPicture( _
　　Filename:=FName, _
　　LinkToFile:=False, _
　　SaveWithDocument:=False, _
　　Left:=.Left, _
　　Top:=.Top, _
　　Width:=0, _
　　Height:=0)
　End With
　With oShape
　　'オリジナルスケールを維持する
　　.ScaleHeight 1, msoTrue
　　.ScaleWidth 1, msoTrue
　　ht = .Height
　　wd = .Width
　　
　　.Placement = xlMove　'結合セルに固定しているのに、これが必要かは不明
　　.LockAspectRatio = msoTrue
　　.Height = mRng.Height
　　
　　If wd > mRng.Width Then
　　　.Width = mRng.Width
　　End If
　End With

ErrHandler:
　If Err() <> 0 Then
　　MsgBox Err.Number & ": " & Err.Description, vbExclamation
　End If
　Application.ScreenUpdating = True

End Sub
'///

この回答へのお礼

回答ありがとうございます。
返答が遅れ申し訳ありません。

とりあえず、そっくり入替えてためしてみましたが、エラーとなるようです。

centerに納まるというのは、画像のリスペクト比を維持したままで縮小すると
場合によっては、セルに余白が出来てしまうからということです。

言い回しが合っているかが疑問ですが、ご理解いただけますでしょうか。
こちらでも、エラーの対処について考えて見ます。

お礼日時：2015/07/04 13:23