![](http://oshiete.xgoo.jp/images/v2/pc/qa/question_title.png?e8efa67b6d)
写真をセルに挿入するマクロをよく見ますが、以前から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
A 回答 (1件)
- 最新から表示
- 回答順に表示
No.1
- 回答日時:
ご質問の内容をまとめると、
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に納まるというのは、画像のリスペクト比を維持したままで縮小すると
場合によっては、セルに余白が出来てしまうからということです。
言い回しが合っているかが疑問ですが、ご理解いただけますでしょうか。
こちらでも、エラーの対処について考えて見ます。
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・【あるあるbot連動企画】あるあるbotに投稿したけど採用されなかったあるある募集
- ・【あるあるbot連動企画】フォロワー20万人のアカウントであなたのあるあるを披露してみませんか?
- ・映画のエンドロール観る派?観ない派?
- ・海外旅行から帰ってきたら、まず何を食べる?
- ・誕生日にもらった意外なもの
- ・天使と悪魔選手権
- ・ちょっと先の未来クイズ第2問
- ・【大喜利】【投稿~9/7】 ロボットの住む世界で流行ってる罰ゲームとは?
- ・推しミネラルウォーターはありますか?
- ・都道府県穴埋めゲーム
- ・この人頭いいなと思ったエピソード
- ・準・究極の選択
- ・ゆるやかでぃべーと タイムマシンを破壊すべきか。
- ・「I love you」 をかっこよく翻訳してみてください
- ・歩いた自慢大会
- ・許せない心理テスト
- ・字面がカッコいい英単語
- ・昔のあなたへのアドバイス
- ・かっこよく答えてください!!
- ・あなたが好きな本屋さんを教えてください
- ・これ何て呼びますか Part2
- ・人生で一番思い出に残ってる靴
- ・ゆるやかでぃべーと すべての高校生はアルバイトをするべきだ。
- ・初めて自分の家と他人の家が違う、と意識した時
- ・単二電池
- ・チョコミントアイス
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
i=cells(Rows.Count, 1)とi=cel...
-
ExcelVBAを使って、値...
-
EXCELで変数をペーストしたい
-
【Excel VBA】指定行以降をクリ...
-
VBからEXCELのセルの値を取得す...
-
特定のセルが空白だったら、そ...
-
vba 隣のセルに値がある行だけ...
-
vb.netによるEXCEL値取得
-
Excelで指定した日付から過去の...
-
特定の文字を条件に行挿入とそ...
-
実行時エラー438 オブジェクト...
-
連続する複数のセル値がすべて0...
-
Excel VBAで、 ヘッダーへのセ...
-
指定した条件で行セルを非表示...
-
”戻り値”が変化したときに、マ...
-
セルの結果でマクロ実行
-
Excle VBA Findメソッドについて
-
DataGridViewで列、行、セルの選択
-
VBAで行削除できないようにする...
-
Excel vbaで特定の文字以外が入...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
i=cells(Rows.Count, 1)とi=cel...
-
ExcelVBAを使って、値...
-
【Excel VBA】指定行以降をクリ...
-
特定のセルが空白だったら、そ...
-
EXCELで変数をペーストしたい
-
Excelで指定した日付から過去の...
-
VBAの間違い教えて下さい
-
【Excel】指定したセルの名前で...
-
Excelのプルダウンで2列分の情...
-
エクセルVBAでコピーして順...
-
Excel vbaで特定の文字以外が入...
-
Excel VBA、 別ブックの最終行...
-
【VBA】指定したセルと同じ値で...
-
特定の文字を条件に行挿入とそ...
-
TODAY()で設定したセルの日付...
-
screenupdatingが機能しなくて...
-
VBA初心者です。次のVBAコード...
-
指定した条件で行セルを非表示...
-
VBAでセルをクリックする回...
-
DataGridViewの各セル幅を自由...
おすすめ情報