| |
βさん
アドバイスいただきありがとうございました。
ご紹介いただいたページや他のページを参考に試行錯誤してますが
残念ながら未だに完成しておりません。
何処が悪いのでしょうか。
ご教授いただけないでしょうか。
Public Sub CCC()
Dim myRange As Range '画像を配置するセル範囲
Dim rX, rY As Double
Dim myDhape, myPic As Variant
Dim Cancel As Boolean
Dim SpObj As Object
Dim sp As Shape
myPic = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif")
If VarType(myPic) = vbBoolean Then Exit Sub
Set myRange = ActiveCell.MergeArea 'このセル範囲に収まるように画像を縮小する
Application.ScreenUpdating = False
With ActiveSheet.Pictures.Insert(myPic).ShapeRange
rX = myRange.Width / .Width
rY = myRange.Height / .Height
If rX > rY Then
.Height = .Height * rY
Else
.Width = .Width * rX
End If
'----------------------追加--------------------------------------------
'For Each sp In ActiveSheet.Shapes
Set sp = Range(sp.TopLeftCell, sp.BottomRightCell)
sp.Select
Selection.Cut
ActiveSheet.PasteSpecial Format:="図 (JPEG)", Link:=False, DisplayAsIcon:=False
DoEvents
With ActiveSheet.Shapes(ActiveSheet.Shapes.Count)
.Left = ActiveCell.Left + (myRange.Width - .Width) / 2 '写真を横方向の中央に配置
.Top = ActiveCell.Top + (myRange.Height - .Height) / 2 '写真を縦方向に中央に配置
End With
' Next
'--------------------------------------------------------------------
End With
Application.ScreenUpdating = True
Cancel = True
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
