ここから本文です

エクセル2010以降でPictures.Insertを使うと画像がリンクになるみたいで・・・ ...

arinko_baskeさん

2017/11/613:31:55

エクセル2010以降でPictures.Insertを使うと画像がリンクになるみたいで・・・

下記は、現在使用しており、ファイルパスを入れたセルに画像を自動挿入するコードとなっています。
Shapes.AddPictureを使えばよいとネ

ットで見たのですが、
素人なので書き換え方が分かりません。
ご存知方教えていただきたいです。
よろしくお願いいたします。

↓現在コード

Private Sub Worksheet_SelectionChange(ByVal Target As Range)

Dim Range_Adrs As String 'アクティブセルのアドレスバックアップ
Dim aFile As Variant '画像ファイル名
Dim i As Integer '画像ファイル名の添字
Dim Cell_Width As Single '画像挿入エリアの幅
Dim Cell_Height As Single '画像挿入エリアの高さ
Dim Row_Str As String 'アクティブセルの行(1:1)アドレス
Dim Column_Str As String 'アクティブセルの列(A:A)アドレス
Dim Cell_Top As Single '画像挿入エリアの上
Dim Cell_Left As Single '画像挿入エリアの左

If ActiveCell.Column = 2 Then
Flg = 1
ElseIf ActiveCell.Column = 14 Then
Flg = 0
Else
Exit Sub
End If

---省略---

Cell_Top = ActiveCell.Top
Cell_Left = ActiveCell.Left

Cell_Width = Columns(Column_Str).Width
Cell_Height = Rows(Row_Str).Height

aFile = Application.GetOpenFilename _
("すべての図 (*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.bmz;*.gif;*.gfa;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg), *.jpg", , , , True)
If IsArray(aFile) Then
For i = 1 To UBound(aFile)
' Debug.Print i & ":", aFile(i)
Next i
Else
' Debug.Print aFile
Exit Sub
End If

' ActiveSheet.Shapes("Picture 4").Select
ActiveSheet.Shapes.AddPicture(aFile(1)).Select '画像を挿入
Selection.ShapeRange.LockAspectRatio = msoTrue '縦横比を固定
'Debug.Print "Selection.ShapeRange.Width (1) = " & Selection.ShapeRange.Width
Selection.ShapeRange.Width = Cell_Width '画像の横幅調整
'Debug.Print "Selection.ShapeRange.Width (2) = " & Selection.ShapeRange.Width
'最初に横幅で合せた時に縦幅がはみ出た場合は縦幅に合せて画像サイズを変更する
'Debug.Print "Selection.ShapeRange.Height (1) = " & Selection.ShapeRange.Height
If Cell_Height < Selection.ShapeRange.Height Then
' 画像をセルの高さに合せる。
Selection.ShapeRange.LockAspectRatio = msoTrue '縦横比を固定
Selection.ShapeRange.Height = Cell_Height '画像の縦幅調整
End If
'Debug.Print "Selection.ShapeRange.Height (2) = " & Selection.ShapeRange.Height

'画像をセルの中央に移動する。
If Selection.ShapeRange.Width < Cell_Width Then
' If Flg = 1 Then
' Selection.ShapeRange.IncrementLeft ((Cell_Width - Selection.ShapeRange.Width))
' End If
Selection.ShapeRange.IncrementLeft (Cell_Left + (Cell_Width - Selection.ShapeRange.Width) / 2 - 50)
Selection.ShapeRange.IncrementTop (Cell_Top - 50)
End If
If Selection.ShapeRange.Height < Cell_Height Then
' Selection.ShapeRange.IncrementTop ((Cell_Height - Selection.ShapeRange.Height) / 2)
Selection.ShapeRange.IncrementLeft (Cell_Left - 50)
Selection.ShapeRange.IncrementTop (Cell_Top + (Cell_Height - Selection.ShapeRange.Height) / 2 - 50)
End If

---省略---

End Sub

閲覧数:
36
回答数:
1

違反報告

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

プロフィール画像

カテゴリマスター

kkyy5223さん

2017/11/614:15:14

前のコードと修正中が混在してしまっているようなので、全部書き直しました。
希望と動きが違うようであればお知らせ下さい。

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim Cell_Width As Double
Dim Cell_Height As Double
Dim aFile As String
Dim shp As Object
Dim Cell_Top As Double
Dim Cell_Left As Double
If Target.Column <> 2 And Target.Column <> 14 Then Exit Sub
Cell_Width = Columns(1).Width
Cell_Height = Rows(1).Height
aFile = Application.GetOpenFilename("すべての図 (*.emf;*.wmf;*.jpg;*.jpeg;*.jfif;*.jpe;*.png;*.bmp;*.dib;*.rle;*.bmz;*.gif;*.gfa;*.emz;*.wmz;*.pcz;*.tif;*.tiff;*.cgm;*.eps;*.pct;*.pict;*.wpg), *.jpg")
If aFile = "False" Then Exit Sub
'写真の比率
Set shp = LoadPicture(aFile)
If (shp.Width / Cell_Width) > (shp.Height / Cell_Height) Then
Cell_Left = Cell_Width
Cell_Top = shp.Height / (shp.Width / Cell_Width)
Else
Cell_Left = shp.Width / (shp.Height / Cell_Height)
Cell_Top = Cell_Height
End If
With Target
Set shp = ActiveSheet.Shapes.AddPicture(Filename:=aFile, LinkToFile:=False, SaveWithDocument:=True, _
Left:=.Left + (Cell_Width - Cell_Left) / 2, Top:=.Top + (Cell_Height - Cell_Top) / 2, Width:=Cell_Left, Height:=Cell_Top)
End With
End Sub

  • 質問者

    arinko_baskeさん

    2017/11/616:48:29

    早々のご対応有難うございます。

    失礼ながら、早速コピーして使用させていただきました。

    添付したところ写真がかなり小さくなってしまいました。

    セルを結合している所をクリックし

    フィットするようにしたいです。

    大変申し訳ございませんが、ご教授お願いできませんでしょうか。

  • その他の返信(2件)を表示

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

  • 取り消す
  • キャンセル

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

2017/11/7 09:00:25

kkyy5223さん

回答有難うございます。

全てがうまくいき、動作も速くなったようにみえます。

バージョンが新しくなり困っておりましたが、

おかげさまで助かりました。

大変有難うございました。

「以降とは」の検索結果

検索結果をもっと見る

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

5文字以上入力してください

別のキーワードで検索:

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

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

閉じる

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