エクセルマクロでダブルクリックして
画像貼り付けでサイズ設定したいです。
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ベストアンサー
- 回答日時:
私としては、ずいぶん長い間、こういうマクロはやったことがなかったのですが、ボケていなかったようで安心です。
本日、雨天ですので調子がよいのです。さて、真ん中……?
継ぎ足しですが、こんなふうに計算して入れました。ただし、画像よりもセルが小さい場合は、働きません。(画像の一番下と次のセルの間を計って、その半分を上からずらす。横も同様です)
'//
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
'
No.1
- 回答日時:
長い間、このようなマクロは書いたことがないので、間違いが見つかるかもしれません。
また、このコードでわざと別のコマンドが残していますが、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が見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) 【VBA】写真の貼り付けコードがうまく機能しません。 5 2022/09/01 18:43
- Excel(エクセル) Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて 2 2022/11/15 16:14
- Excel(エクセル) 【マクロ】スクショ印刷がうまく動かない件 5 2022/12/06 17:37
- Visual Basic(VBA) 【Excel VBA】自動メール送信の機能追加 5 2022/09/29 12:53
- Visual Basic(VBA) 【VBA】写真の縦横比を変えずに貼り付ける 5 2023/06/13 11:42
- Visual Basic(VBA) 【追加】ファイルを閉じてダイアログで保存した時だけ処理の実行をする 3 2022/03/23 15:43
- Excel(エクセル) VBAについて 3 2022/06/19 18:19
- Excel(エクセル) エクセル VBA For Next 繰り返しの書き方を教えてください 6 2022/09/01 14:11
- Visual Basic(VBA) 【変更】ファイルを閉じてダイアログで保存した時、更新したシートだけの処理の実行をする 5 2022/03/26 18:31
- Excel(エクセル) エクセルVBAでオブジェクトが必要です 2 2022/09/10 16:37
このQ&Aを見た人はこんなQ&Aも見ています
-
「環境が人を育てる」って本当?環境によって人格や生き方は本当に変わるのか
環境が人生に与える影響は実際どれほどのものなのか、専門家の田宮由美さんに伺った。
-
【EXCEL VBA】ダブルクリックでセルのサイズに合わせて画像を挿入に機能を追加したいです。
Visual Basic(VBA)
-
【VBA】写真の貼り付けコードがうまく機能しません。
Visual Basic(VBA)
-
ダブルクリックで貼り付けた画像からリンクのみ削除し、画像を残したい
Visual Basic(VBA)
-
-
4
マクロで画像挿入→エラー「リンクされたイメージを表
Excel(エクセル)
-
5
セルをダブルクリックで、画像を選択、挿入したい時
Excel(エクセル)
-
6
Excel2019 マクロを使用し画像を貼り付けした際のリンク切れについて
Excel(エクセル)
-
7
VBAでエクセルのシート上の画像のリサイズと配置を行いたい
Excel(エクセル)
-
8
Excel 画像貼り付けのVBAについて
Excel(エクセル)
-
9
【VBA】写真の縦横比を変えずに貼り付ける
Visual Basic(VBA)
関連するカテゴリからQ&Aを探す
おすすめ情報
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
男の人はやってるとき 彼女がす...
-
高校生です。彼氏の前で初めて...
-
彼と体の相性が良すぎて悩んで...
-
夫婦の夜の営みについてです。 ...
-
女性が喘いでいるときの男性の...
-
抱きしめたときに勃起したあそ...
-
もし週1しか恋人と会えなかった...
-
彼氏と毎日セックスするのは異...
-
彼女が感じやすくて可愛い
-
男性の方に質問です。 バックで...
-
兄妹や姉弟で、キスやエッチし...
-
クンニしたことある人ー ま○こ...
-
男性に質問です! 電話だけで勃...
-
初体験って気持ちいいの? 男の...
-
男の人ってなんですぐ勃つの?...
-
彼氏のセックスが下手すぎで幻...
-
セックス中に動画や写真を撮る...
-
彼女がフェラをしてくれません。
-
ふぇらでイカセテくれる うまい...
-
実家住まいの場合Hはホテル以外...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
男の人はやってるとき 彼女がす...
-
彼と体の相性が良すぎて悩んで...
-
女性が喘いでいるときの男性の...
-
高校生です。彼氏の前で初めて...
-
夫婦の夜の営みについてです。 ...
-
男性の方に質問です。 バックで...
-
抱きしめたときに勃起したあそ...
-
彼女が感じやすくて可愛い
-
男の人ってなんですぐ勃つの?...
-
もし週1しか恋人と会えなかった...
-
彼氏と毎日セックスするのは異...
-
クンニしたことある人ー ま○こ...
-
キスすれば相手を好きでなくて...
-
彼氏のセックスが下手すぎで幻...
-
実家住まいの場合Hはホテル以外...
-
ふぇらでイカセテくれる うまい...
-
男性に質問です! 電話だけで勃...
-
兄妹や姉弟で、キスやエッチし...
-
彼女がフェラをしてくれません。
-
セックス中に動画や写真を撮る...
おすすめ情報