| |
こんにちは
>目的は
> 指定セルをダブルクリック、フォルダを開き画像選択
> 画像挿入（指定したサイズまたはセルのｗｈ合わせ）、
> 挿入された画像を切り取り、形式（Jpeg）を指定して貼付
> 貼付た画像をセル内で上下センタリング
>としたいのです。
これは元々のコードで出来ているのでは？
ブックのファイルサイズが大きいなら、βさんのリンク先のコードで
出来ると思いますし。
質問の意味がよく分からないですが、
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myPic As Variant
Dim myRange As Range
Dim rX As Single
Dim rY As Single
Dim cht As Chart
Dim tmpP As String
Dim tmpS As Worksheet
Dim tmpR As Range
'挿入のセルを指定
If Application.Intersect(Target, Range("D6,D23,D40")) Is Nothing Then Exit Sub
Cancel = True
'写真挿入
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If myPic = False Then
Application.ScreenUpdating = True
MsgBox "画像を選択してください"
Exit Sub
End If
Application.ScreenUpdating = False
tmpP = CreateObject("WScript.Shell").SpecialFolders("Desktop") & "\"
Set tmpS = Worksheets.Add
ActiveWindow.DisplayGridlines = False
Set tmpR = tmpS.Range("A1")
Set myRange = Target 'このセル範囲に収まるように画像を縮小する
With Me.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
tmpR.RowHeight = .Height
tmpR.ColumnWidth = .Width / 6
.Left = .Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
.Top = .Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
.ZOrder msoSendToBack '最背面へ移動
tmpS.Shapes.AddPicture myPic, False, True, tmpR.Left, tmpR.Top, tmpR.Width, tmpR.Height
.Delete
End With
tmpS.Activate
tmpR.Select
tmpR.CopyPicture appearance:=xlScreen, Format:=xlPicture
'画像貼り付け用の埋め込みグラフを作成
Set cht = ActiveSheet.ChartObjects.Add(0, 0, tmpR.Width, tmpR.Height).Chart
'埋め込みグラフに貼り付ける
cht.Paste
'JPEG形式で保存
cht.Export Filename:=tmpP & Dir(myPic), filtername:="JPG"
'埋め込みグラフを削除
cht.Parent.Delete
With Me.Shapes.AddPicture(tmpP & Dir(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 tmpP & Dir(myPic)
End With
Application.DisplayAlerts = False
tmpS.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Cancel = True
End Sub
とかでは、余計にダメでしょうか？
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
