ここから本文です

エクセルに画像をダブルクリックで挿入する方法があると思いますが、うまくいきま...

mn4********さん

2018/3/315:51:45

エクセルに画像をダブルクリックで挿入する方法があると思いますが、うまくいきません。以前にこちらで回答にあった以下のマクロをコピペしてみたのですが、この式だと画像にリンクを張って表示するようになっている

ようで元の画像が消えたり保存場所を変えると表示されなくなってしまいます。この式を応用してエクセルに画像が保存できるようにできないでしょうか?
■使用マクロ■
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim PicFile As Variant
Dim rX As Double, rY As Double

If Intersect(Target, Range("B6,B29,B54,B77,B102,B125")) Is Nothing Then Exit Sub

'[ファイルを開く]ダイアログボックスを表示
PicFile = Application.GetOpenFilename( _
"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub

Application.ScreenUpdating = False

'画像を挿入
With ActiveSheet.Pictures.Insert(PicFile)
rX = Target.Width / .Width
rY = Target.Height / .Height
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If

'セルの中央(横方向/縦方向の中央)に配置
.Left = Target.Left + (Target.Width - .Width) / 2
.Top = Target.Top + (Target.Height - .Height) / 2
End With

Application.ScreenUpdating = True
Cancel = True
End Sub

閲覧数:
882
回答数:
4

違反報告

ベストアンサーに選ばれた回答

プロフィール画像

カテゴリマスター

tra********さん

2018/3/416:41:14

With ActiveSheet.Pictures.Insert(PicFile)
rX = Target.Width / .Width
rY = Target.Height / .Height



With ActiveSheet.Pictures.Insert(PicFile)
.CopyPicture 'クリップボードにコピー
.Delete '画像を削除
End With
ActiveSheet.Paste '画像を貼り付け
With Selection
rX = Target.Width / .Width
rY = Target.Height / .Height

質問した人からのコメント

2018/3/8 16:55:20

様々なご回答ありがとうございます。それぞれ試させていただき、非常に参考になりました。
そのなかでも一番手軽に修正が実現したこちらの回答をベストアンサーとさせていただきました。
本当にありがとうございましたm(__)m

このQ&Aで解決しましたか?質問する

閉じる

ベストアンサー以外の回答

1〜3件/3件中

並び替え:回答日時の
新しい順
|古い順

だるまさん

2018/3/414:35:37

画像貼り付け用の下記クラスモジュールを使用したコードです。

<<< cLoadPicture クラスモジュールの設定方法 >>>

http://hp.vector.co.jp/authors/VA033788/kowaza.html#0223

上記リンク先にある、

===== cLoadPicture クラスモジュール ===== の下、
Option Explicit 以下のコードを「クラスモジュール」にコピペして下さい。

クラスモジュールの挿入は、[挿入]-[クラスモジュール]メニューです。

そして、そのクラスモジュールの名前(オブジェクト名)を
「Class1」から「cLoadPicture」と変更して下さい。

<<< 設定方法 ここまで >>>


上記設定が完了しているとして、以下のコードをシートモジュールに
コピペして下さい。


Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, _
Cancel As Boolean)
Dim PicFile As Variant

If Intersect(Target, Range("B6,B29,B54,B77,B102,B125")) Is Nothing Then Exit Sub

'[ファイルを開く]ダイアログボックスを表示
PicFile = Application.GetOpenFilename( _
"画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub

Dim cLP As cLoadPicture
Set cLP = New cLoadPicture

With cLP
.Margin = 0 'セルとの隙間設定
Set .LoadPointCell = Target '読み込み先セル指定
.PictureFullPath = PicFile '画像フルパス
.LoadPicture '画像読み込み実行
End With

Set cLP = Nothing

Cancel = True
End Sub

otu********さん

2018/3/323:51:12

with ~end withで
セルの高さのみ合わせて 縦の物は横にしてみました。


Dim expan1 As Double, expan2 As Double

With ActiveSheet.Shapes.AddPicture( _
Filename:=PicFile, _
LinkToFile:=False, _
SaveWithDocument:=True, _
Left:=target.Left, Top:=target.Top, Width:=0, Height:=0)
.ScaleHeight 1, msoTrue
.ScaleWidth 1, msoTrue
expan1 = target.Height / .Height
.Width = .Width * expan1
.Height = .Height * expan1
If Abs(.Left - target.Left) > 10 Then
.IncrementRotation 90
.Left = target.Left
.Top = target.Top
End If
If .Width < .Height Then
.IncrementRotation 90
expan2 = .Height / .Width
.Height = .Height * expan2
.Width = .Width * expan2
.Left = target.Left + (.Height - .Width) / 2
.Top = target.Top - (.Height - .Width) / 2
End If
End With

返信を取り消しますが
よろしいですか?

  • 取り消す
  • キャンセル

m3_maki0さん

2018/3/319:12:41

こちらが参考になるのでは?

Excel 2010 で Pictures.Insert メソッドを使用して図をワークシートに挿入すると図がリンク オブジェクトとして挿入される
https://support.microsoft.com/ja-jp/help/2396509#!/ja-jp/help/23965...

みんなで作る知恵袋 悩みや疑問、なんでも気軽にきいちゃおう!

Q&Aをキーワードで検索:

Yahoo! JAPANは、回答に記載された内容の信ぴょう性、正確性を保証しておりません。
お客様自身の責任と判断で、ご利用ください。
本文はここまでです このページの先頭へ

「追加する」ボタンを押してください。

閉じる

※知恵コレクションに追加された質問は選択されたID/ニックネームのMy知恵袋で確認できます。

不適切な投稿でないことを報告しました。

閉じる