画像をアクティブセルの左上隅に配置し任意のセルに

質問

画像をアクティブセルの左上隅に配置し任意のセルにその画像ファイル名を自動で入力したいです

やりたいことは以下になります

例えば画像をアクティブセル（D2）の左上隅に貼り付けて

貼り付けた画像のファイル名をC2に自動で入力をしたいです

ファイル名に関しては拡張子も明記するコードとしないコード二つご教授して頂けると大変嬉しいです

下記のコード二つを組み合わせればできそうなんですが

どのようにしたらいいのか分かりません

よろしくお願いします

Sub 図形挿入()
Dim FilePath As Variant
FilePath = Application.GetOpenFilename(",*.png")
If Not FilePath = False Then
ActiveSheet.Pictures.Insert(FilePath).Select
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Width = Selection.ShapeRange.Width * 1#
Selection.ShapeRange.Left = ActiveCell.Left + 2.25
Selection.ShapeRange.Top = ActiveCell.Top + 2.25
With Selection.ShapeRange.Line
.Weight = 2.25 '線の太さを2.25に
.ForeColor.RGB = RGB(255, 0, 0) '赤枠に

End With
End If

End Sub

Sub ファイル名をセルに入力()
Dim OpenFileName As String
Dim tmp As Variant
OpenFileName = Application.GetOpenFilename(FileFilter:="画像 ,*.png; *.jpg; *.gif; *.bmp", Title:="ファイルの選択")
If OpenFileName <> "False" Then
tmp = Split(OpenFileName, "\")
Range("C2").Value = tmp(UBound(tmp))
End If
End Sub

回答No.1

keithin · ベストアンサー

sub macro1()
　dim myFile as string
　myfile = application.getopenfilename(FileFilter:="画像 ,*.png; *.jpg; *.gif; *.bmp", Title:="ファイルの選択")
　if myfile = "False" then exit sub
　if activecell.row = 1 then activecell.offset(1).select

　ActiveSheet.Pictures.Insert(myfile).Select
　Selection.ShapeRange.LockAspectRatio = msoTrue
　Selection.ShapeRange.Width = Selection.ShapeRange.Width * 1#
　Selection.ShapeRange.Left = ActiveCell.Left + 2.25
　Selection.ShapeRange.Top = ActiveCell.Top + 2.25
　With Selection.ShapeRange.Line
　　.Weight = 2.25 '線の太さを2.25に
　　.ForeColor.RGB = RGB(255, 0, 0) '赤枠に
　End With

　myfile = dir(myfile)
'拡張子を表示したくないときは下記を生かす
'myfile = left(myfile, instr( myfile, ".") -1)

　activecell.offset(-1, 0) = myfile
end sub

みたいな。

お礼

ありがとうございます
的確にご教授頂けて嬉しいです
困っていたので嬉しいです

回答No.2

watabe007

>・・・RGB(255, 0, 0) '赤枠に
赤枠を表示するのなら　Line.Visible = msoTrue としなければ

Sub 図形挿入()
　　Dim FilePath As Variant

　　FilePath = Application.GetOpenFilename(FileFilter:="画像 ,*.png; *.jpg; *.gif; *.bmp", Title:="ファイルの選択")
　　If FilePath = False Then Exit Sub
　　With ActiveSheet.Pictures.Insert(FilePath).ShapeRange
　　　　.LockAspectRatio = msoTrue
　　　　.Width = .Width * 1#
　　　　.Left = ActiveCell.Left + 2.25
　　　　.Top = ActiveCell.Top + 2.25
　　　　With .Line
　　　　　　.Weight = 2.25
　　　　　　.Visible = msoTrue '線を表示
　　　　　　.ForeColor.RGB = RGB(255, 0, 0) '赤枠に
　　　　End With
　　End With
　　ActiveCell.Offset(0, -1) = Dir(FilePath)
　　'拡張子を表示しない場合
　　'ActiveCell.Offset(0, -1) = Split(Dir(FilePath), ".")(0)
End Sub

お礼

ありがとうございます
まさにやりたいことです
大変助かりました
嬉しいです