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

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

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に変更したいです。

どうぞよろしくお願いします。

No.2 ベストアンサー 回答者： WindFaller 回答日時： 2016/06/16 19:26

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

本日、雨天ですので調子がよいのです。

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

'//
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
'

この回答へのお礼

ありがとうございます！！
このマクロのおかげで、作業効率がかなり上がりました！！
本当に助かりました。
ありがとうございます。

お礼日時：2016/06/17 10:20

No.1 回答者： WindFaller 回答日時： 2016/06/16 10:18

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

また、このコードでわざと別のコマンドが残していますが、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

この回答へのお礼

ありがとうございます！！！

画像うまく貼れるようになりました。

もう一つお願いしたいのですが、

修正して頂いたマクロで

セルの中央に画像がくるようにならないでしょうか？

今のマクロではセルの左上に画像が貼られるので。。

何度の申し訳ございません。

よろしくお願いいたします。。

お礼日時：2016/06/16 18:09