|
こんにちは
セルに貼り付けた画像のサイズにして良ければ、
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant
Dim mySp As Object
Dim myAD1 As String
Dim myAD2 As String
Dim myHH As Double
Dim myWW As Double
Dim myHH2 As Double
Dim myWW2 As Double
Dim myPic As Variant
Dim myRange As Range
Dim rX As Single
Dim rY As Single
Dim cht As Chart
'挿入のセルを指定
If Application.Intersect(Target, Range("D6,D23,D40")) Is Nothing Then Exit Sub
Cancel = True
Application.ScreenUpdating = False
'写真挿入
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If myPic = False Then
Application.ScreenUpdating = True
MsgBox "画像を選択してください"
Exit Sub
End If
Set myRange = Target 'このセル範囲に収まるように画像を縮小する
Application.ScreenUpdating = False
With ActiveSheet.Shapes.AddPicture(myPic, False, True, myRange.Left, myRange.Top, myRange.Width, myRange.Height)
rX = 0.85
rY = 1
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If
.Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
.Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
.ZOrder msoSendToBack '最背面へ移動
Kill myPic
End With
myRange.Select
myRange.CopyPicture appearance:=xlScreen, Format:=xlPicture
'画像貼り付け用の埋め込みグラフを作成
Set cht = ActiveSheet.ChartObjects.Add(0, 0, myRange.Width + 1, myRange.Height + 1).Chart
'埋め込みグラフに貼り付ける
cht.Paste
'JPEG形式で保存
cht.Export Filename:=myPic, filtername:="JPG"
'埋め込みグラフを削除
cht.Parent.Delete
Application.ScreenUpdating = True
Cancel = True
End Sub
とかでどうでしょうか?
元画像を削除しますのでテスト環境で試して下さい。
|
|