エクセルマクロでダブルクリックして画像貼り付けでサイズ設定したいです。

Question

エクセルマクロでダブルクリックして
画像貼り付けでサイズ設定したいです。

web上で見つけたマクロです。画像のサイズを指定したいのですができません。
私はマクロ初心者の為。どうかよろしくお願い致します。

以下のマクロです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
 Dim PicFile As Variant, P As Object
 Dim objSahpe As Shape
 Dim rX As Double, rY As Double
 Dim r1 As Double, r2 As Double
 If Intersect(Target, Range("A11,A24,A37,A50,I11,I24,I37,I50,Q11,Q24,Q37,Q50")) Is Nothing Then Exit Sub
 '［ファイルを開く］ダイアログボックスを表示
PicFile = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp")
 If VarType(PicFile) = vbBoolean Then Cancel = True: Exit Sub
 Application.ScreenUpdating = False
 '画像を挿入
Set P = LoadPicture(PicFile)
 r1 = Target.Width / P.Width / 0.0378
 r2 = Target.Height / P.Height / 0.0378
 If r1 >= r2 Then
 rX = Target.Width * 0.0378 * r2
 rY = Target.Height
 Else
 rX = Target.Width
 rY = P.Height * 0.0378 * r1
 End If
 With Target
 Set objShape = ActiveSheet.Shapes.AddPicture(Filename:=PicFile, LinkToFile:=False, SaveWithDocument:=True, _
 Left:=Target.Left + (Target.Width - rX) / 2, _
 Top:=Target.Top + (Target.Height - rY) / 2, _
 Width:=rX, _
 Height:=rY)
 End With
 Application.ScreenUpdating = True
 Cancel = True
 End Sub


画像を貼り付けることはできましたが、
このまま使用すると縦長に細い線のように貼り付けられます。

画像サイズは
縦が3.9cm
横が5.2cmに変更したいです。

どうぞよろしくお願いします。

WindFaller · Accepted Answer

私としては、ずいぶん長い間、こういうマクロはやったことがなかったのですが、ボケていなかったようで安心です。本日、雨天ですので調子がよいのです。

さて、真ん中……？
継ぎ足しですが、こんなふうに計算して入れました。ただし、画像よりもセルが小さい場合は、働きません。(画像の一番下と次のセルの間を計って、その半分を上からずらす。横も同様です）

'//
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
　　Dim myCur As String
　　Dim myPath As String
　　Dim PicFile As Variant, objPic　　As Shape
　　Dim h As Double, y As Double, d As Double, w As Double, x As Double
　　Dim oPDO As Object
　　If Intersect(Target, Range("A11,A24,A37,A50,I11,I24,I37,I50,Q11,Q24,Q37,Q50")) Is Nothing Then GoTo EndLine
　　'［ファイルを開く］ダイアログボックスを表示
　　myCur = CurDir
　　myPath = CreateObject("Shell.Application").Namespace(&H27).Self.Path
　　ChDir myPath
　　PicFile = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp;*.emf;*.wmf,すべて,*.*", , "画像選択")
　　If VarType(PicFile) = vbBoolean Then Exit Sub
　　Application.ScreenUpdating = False
　　'画像を挿入
　　'Set objPic = ActiveSheet.Pictures.Insert(PicFile)
　　Set objPic = ActiveSheet.Shapes.AddPicture(PicFile, False, msoCTrue, Target.Left, Target.Top, 110, 150)
　　With objPic.DrawingObject
　　　　.ShapeRange.LockAspectRatio = msoFalse
　　　　.Left = Target.Left
　　　　.Top = Target.Top
　　　　.Height = Application.CentimetersToPoints(3.9)
　　　　.Width = Application.CentimetersToPoints(5.2)
　　End With
　　Set oPDO = objPic.DrawingObject
　　With Target　　'真ん中に置くための計算
　　　　h = .Top + oPDO.Height
　　　　y = .Offset(1).Top
　　　　If y > h Then
　　　　　　d = (y - h) / 2
　　　　　　oPDO.Top = .Top + d
　　　　End If
　　　　w = .Left + oPDO.Width
　　　　x = .Offset(, 1).Left
　　　　If x > w Then
　　　　　　d = (x - w) / 2
　　　　　　oPDO.Left = .Left + d
　　　　End If
　　End With
　　Application.ScreenUpdating = True
EndLine:
　　If myCur <> "" Then
　　　　ChDir myCur
　　End If
End Sub
'

WindFaller · Answer

長い間、このようなマクロは書いたことがないので、間違いが見つかるかもしれません。また、このコードでわざと別のコマンドが残していますが、Pictures.Insert とShapes.AddPicture　では、前者は元の画像と紐付になってしまうので、勝手が悪いという話を聞いたことがあります。自分が後で見るために、残しておきました。

縦が3.9cm
横が5.2cm
これは、一応念のためですが、画像がその大きさであって、見える部分が必ずしも、3.9×5.2 cmではありません。もう一つは、実際のプリントでは誤差は避けられませんので、一端印刷した画像の大きさと元の論理的な数値とを比較して、誤差修正してください。
'//

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
　　Cancel = True
　　Dim myCur As String
　　Dim myPath As String
　　Dim PicFile As Variant, objPic　　As Shape
　　If Intersect(Target, Range("A11,A24,A37,A50,I11,I24,I37,I50,Q11,Q24,Q37,Q50")) Is Nothing Then GoTo EndLine
　　'［ファイルを開く］ダイアログボックスを表示
　　myCur = CurDir
　　myPath = CreateObject("Shell.Application").Namespace(&H27).Self.Path
　　ChDir myPath
　　PicFile = Application.GetOpenFilename("画像ファイル,*.jpg;*.jpeg;*.gif;*.tif;*.png;*.bmp;*.emf;*.wmf,すべて,*.*", , "画像選択")
　　If VarType(PicFile) = vbBoolean Then Exit Sub
　　Application.ScreenUpdating = False
　　'画像を挿入
　　'Set objPic = ActiveSheet.Pictures.Insert(PicFile)
　　Set objPic = ActiveSheet.Shapes.AddPicture(PicFile, False, msoCTrue, Target.Left, Target.Top, 110, 150)
　　With objPic.DrawingObject
　　　　　　.ShapeRange.LockAspectRatio = msoFalse
　　　　　　.Left = Target.Left + 1
　　　　　　.Top = Target.Top + 1
　　　　　　.Height = Application.CentimetersToPoints(3.9)
　　　　　　.Width = Application.CentimetersToPoints(5.2)
　　End With
　　Application.ScreenUpdating = True
EndLine:
　　If myCur <> "" Then
　　　　ChDir myCur
　　End If
End Sub

エクセルマクロでダブルクリックして画像貼り付けでサイズ設定したいです。

長い間、このようなマクロは書いたことがないので、間違いが見つかるかもしれません。

私としては、ずいぶん長い間、こういうマクロはやったことがなかったのですが、ボケていなかったようで安心です。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング