写真をセルに挿入するマクロをよく見ますが、以前から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を探す
おすすめ情報
- ・漫画をレンタルでお得に読める!
- ・14歳の自分に衝撃の事実を告げてください
- ・架空の映画のネタバレレビュー
- ・「お昼の放送」の思い出
- ・昨日見た夢を教えて下さい
- ・【お題】絵本のタイトル
- ・【大喜利】世界最古のコンビニについて知ってる事を教えてください【投稿~10/10(木)】
- ・メモのコツを教えてください!
- ・CDの保有枚数を教えてください
- ・ホテルを選ぶとき、これだけは譲れない条件TOP3は?
- ・家・車以外で、人生で一番奮発した買い物
- ・人生最悪の忘れ物
- ・【コナン30周年】嘘でしょ!?と思った○○周年を教えて【ハルヒ20周年】
- ・ハマっている「お菓子」を教えて!
- ・最近、いつ泣きましたか?
- ・夏が終わったと感じる瞬間って、どんな時?
- ・10秒目をつむったら…
- ・人生のプチ美学を教えてください!!
- ・あなたの習慣について教えてください!!
- ・牛、豚、鶏、どれか一つ食べられなくなるとしたら?
- ・都道府県穴埋めゲーム
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
エクセルVBAでコピーして順...
-
ExcelVBAを使って、値...
-
i=cells(Rows.Count, 1)とi=cel...
-
【Excel VBA】指定行以降をクリ...
-
EXCELで変数をペーストしたい
-
Excelで指定した日付から過去の...
-
VBAでセルをクリックする回...
-
ExcelのVBAで数字と文字列をマ...
-
VBA実行後に元のセルに戻りたい
-
Excel ユーザーフォームをモー...
-
TODAY()で設定したセルの日付...
-
RC表示に変数を入れる
-
Excelのプルダウンで2列分の情...
-
エクセルの複数データーをダブ...
-
【EXCEL VBA】Range("A:A").Fi...
-
特定のセルが空白だったら、そ...
-
【VBA】シート上の複数のチェッ...
-
【Excel】指定したセルの名前で...
-
vba 隣のセルに値がある行だけ...
-
特定の文字を条件に行挿入とそ...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
ExcelVBAを使って、値...
-
i=cells(Rows.Count, 1)とi=cel...
-
特定のセルが空白だったら、そ...
-
Excelで指定した日付から過去の...
-
【Excel VBA】指定行以降をクリ...
-
EXCELで変数をペーストしたい
-
Excelのプルダウンで2列分の情...
-
【Excel】指定したセルの名前で...
-
Excelシートのあるセルから値を...
-
特定の文字を条件に行挿入とそ...
-
連続する複数のセル値がすべて0...
-
セル色なしの行一括削除
-
指定した条件で行セルを非表示...
-
vba 隣のセルに値がある行だけ...
-
Application.Matchで特定行の検索
-
Excel vbaで特定の文字以外が入...
-
TODAY()で設定したセルの日付...
-
EXCELのVBA-フィルタ抽出後の...
-
【VBA】指定したセルと同じ値で...
-
”戻り値”が変化したときに、マ...
おすすめ情報