[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『エクセル2010 VBA 画像挿入 』(しん)
こちらのサイトで以下のコードを見つけました。
画像を挿入したところ
結合したセルの大きさにジャストサイズに張り付けられます。
元の写真の縦横比を維持しつつ
結合されたセルの中央にしかもできるだけ大きく
貼り付けたいのですが、
どのようにコードを書き直したらよいのかわかりません。
どうか教えていただけないでしょうか。
よろしくお願いいたします。
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double
Cancel = True
'===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If '===============画像の掃除 For Each mySp In ActiveSheet.Shapes myAD1 = mySp.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySp.Delete Next
'===============画像の貼り付け Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _ SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _ Width:=0, Height:=0) '★ とりあえず 縦横0で。 mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す '===============タテヨコの縮尺を保持 If mySp.Width > Target.Width Then mySp.Width = Target.Width If mySp.Height > Target.Height Then mySp.Height = Target.Height '===============中央へ調整 myHH2 = (Target.Height / 2) - (mySp.Height / 2) myWW2 = (Target.Width / 2) - (mySp.Width / 2) mySp.Top = Target.Top + myHH2 mySp.Left = Target.Left + myWW2
Set mySp = Nothing
End Sub
< 使用 Excel:Excel2010、使用 OS:Windows7 >
4/19 17:25 不要なコード2行を削除(あっても害にはなりませんが)
以下ではいかがですか
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double Dim r As Range Dim d As Double
Cancel = True
'===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False) If myF = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If '===============画像の掃除 For Each mySp In ActiveSheet.Shapes myAD1 = mySp.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySp.Delete Next '===============画像の貼り付け Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _ SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _ Width:=0, Height:=0) '★ とりあえず 縦横0で。 mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す
'範囲内で最大になるように加工
With mySp Set r = .TopLeftCell.MergeArea If r.Width / .Width < r.Height / .Height Then d = Application.WorksheetFunction.RoundDown(r.Width / .Width, 2) Else d = Application.WorksheetFunction.RoundDown(r.Height / .Height, 2) End If .ScaleWidth d, msoFalse, msoScaleFromTopLeft .ScaleHeight d, msoFalse, msoScaleFromTopLeft .Left = r.Left + r.Width / 2 - .Width / 2 .Top = r.Top + r.Height / 2 - .Height / 2 End With
Set mySp = Nothing
End Sub
(β) 2015/04/19(日) 13:59
?@横長の結合セルに縦長の写真
?A縦長の結合セルに横長の写真
を挿入したとき
上下左右に余白ができてしまいます。
?@の時はセルの上下に余白なく
?Aの時はセルの左右に余白なく
限られたセルの中で
できるだけ大きく挿入したいのです。
よろしくお願いいたします。
(しん) 2015/04/19(日) 21:28
こちらでは、横長に結合された領域では縦に目いっぱい、左右に余白、縦長に結合されたセルでは横に目いっぱい、上下に余白という結果になります。 (もっとも、長さを計算するために RoundDownをしていますので、わずかな隙間が残るケースはあると思いますが)
具合が悪いケースの結合セルのHeightとWidth、元の画像の縦横比を教えてもらえますか?
追伸 選んだ図そのものが左右あるいは上下に余白があるなんてことはないでしょうね?
(β) 2015/04/19(日) 21:59
どんな写真でもセルの大きさに合わせると言うことでよろしいですか?
この他にも横幅に合わせ、縦は写真比率や複数の選択セルに合わせるなど作りました。
ブックのサイズが大きくなる問題も分けは分かりませんが、コピペで大丈夫、組み込んで見て下さい。
コードは、以下の通りです。
Sub 画像貼付()
Dim StrFilter As String Dim IPicture As Variant Dim MovHeight, MovWidth, MovTop, MovLeft As Double Dim PicData As Object
MovHeight = ActiveCell.MergeArea.Height MovWidth = ActiveCell.MergeArea.Width MovTop = ActiveCell.Top MovLeft = ActiveCell.Left MovHosei = MovWidth
IPicture = "" StrFilter = "IPicture(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
IPicture = Application.GetOpenFilename(FileFilter:=StrFilter, _ FilterIndex:=1, _ Title:="画像ファイルを選択してください。", _ MultiSelect:=False)
Set PicData = LoadPicture(IPicture) Set PicData = ActiveSheet.Shapes.AddPicture(IPicture, True, True, MovLeft, MovTop, MovWidth, MovHeight)
Set PicData = Nothing ActiveCell.Offset(, 1).Select
End Sub
(ko) 2015/04/20(月) 06:53
To (ko) さん
質問者さんの要望は【元画像の縦横比率を維持】したうえで、指定のセル領域に目いっぱいに貼り付けるというものです。
(β) 2015/04/20(月) 07:11
そうですよね。コードを追加します。
Set PicData = LoadPicture(IPicture)
If (MovWidth / MovHeight) > (PicData.Width / PicData.Height) Then MovWidth = MovHeight * (PicData.Width / PicData.Height) Else MovHeight = MovWidth * (PicData.Height / PicData.Width) End If
Set PicData = ActiveSheet.Shapes.AddPicture(IPicture, True, True, MovLeft, MovTop, MovWidth, MovHeight)
(ko) 2015/04/20(月) 08:34
To (ko) さん
かつ、当該領域の「結合されたセルの中央にしかもできるだけ大きく 」のようですよ。
ところで、他の変数は規定しているのに、Dim MovHosei As Double の規定がないのは、何か意図があるのですか?
(β) 2015/04/20(月) 08:44
Dim MovHosei As Double は、忘れているだけです。失礼しました。
この変数は、セルの中央に配置するためでした。
このコードは、IF分の外でも OK ですかね?
改めて、コードをアップしますが、縦長写真の下部に余白が少しでます。
もう少し工夫して下さい。
Sub 画像貼付()
Dim StrFilter As String Dim IPicture As Variant Dim MovHeight, MovWidth, MovTop, MovLeft As Double Dim PicData As Object Dim MovHosei, MovHHosei As Double
MovHeight = ActiveCell.MergeArea.Height MovWidth = ActiveCell.MergeArea.Width MovTop = ActiveCell.Top MovLeft = ActiveCell.Left MovHosei = MovWidth MovHHosei = MovHeight
IPicture = "" StrFilter = "IPicture(*.jpg;*.jpeg;*.gif;*.bmp;*.png),*.jpg;*.jpeg;*.gif;*.bmp;*.png"
IPicture = Application.GetOpenFilename(FileFilter:=StrFilter, _ FilterIndex:=1, _ Title:="画像ファイルを選択してください。", _ MultiSelect:=False)
Set PicData = LoadPicture(IPicture)
If (MovWidth / MovHeight) > (PicData.Width / PicData.Height) Then MovWidth = MovHeight * (PicData.Width / PicData.Height) MovLeft = MovLeft + ((MovHosei - MovWidth) / 2) Else MovHeight = MovWidth * (PicData.Height / PicData.Width) MovTop = MovTop + ((MovHHosei - MovHeight) / 2) End If
Set PicData = ActiveSheet.Shapes.AddPicture(IPicture, True, True, MovLeft, MovTop, MovWidth, MovHeight)
Set PicData = Nothing ActiveCell.Offset(, 1).Select
End Sub
(ko) 2015/04/20(月) 10:18
ところで、私がアップしたコード、ご指摘の余白の件は、???なんですが、 コメントしましたように、RoundDown を使っていますので、心もち、小さくなります。
d = Application.WorksheetFunction.RoundDown(r.Width / .Width, 2)
と
d = Application.WorksheetFunction.RoundDown(r.Height / .Height, 2)
を
d = r.Width / .Width
と
d = r.Height / .Height
に変更すれば、ぴったりになると思います。
(β) 2015/04/20(月) 16:20
koさんおコードを拝見して、
StdPictureオブジェクトから
Shapes.AddPicture(IPicture, True, True, MovLeft, MovTop, MovWidth, MovHeight)
こんなコードが書けるんですねえ 初めて知りました。 これは、今後何かに使えるかもしれません。
ただ、これを使うと 本来のExcelに挿入できる画像ファイルの種類が制限されてしまいます。
Excelは、 PngやTIFの挿入も可能ですから・・・。
ちょっと気になったので・・・。 (ichinose) 2015/04/21(火) 06:07
2010エクセルです。
(ガ−サ) 2015/04/24(金) 11:08
>StdPictureオブジェクトから >Shapes.AddPicture(IPicture, True, True, MovLeft, MovTop, MovWidth, MovHeight) >こんなコードが書けるんですねえ 初めて知りました。 >これは、今後何かに使えるかもしれません。
と先日記述しましたが・・・、オオボケでした。StdPictureに既定のプロパティでもあるのかと ちょっと前に何気に調べてもそれらしいものはなし。
もう一回コードを見直すと 変数IPictureの型は StdPictureではないのですね!!
物食べながらコードを眺めてまともな思考が働く年齢ではありませんでした。
撤回します。
ついでに
「画像のファイル名」は、コードを私のように早とちりせずに解析すれば、 出てくると思いますよ!! まず、コード中のどの変数にそれらしい文字列があるかを 調べてみることです。
(ichinose) 2015/04/24(金) 12:51
Option Explicit
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)
Dim myF As Variant Dim mySp As Object Dim myAD1 As String Dim myAD2 As String Dim myHH As Double Dim myWW As Double Dim myHH2 As Double Dim myWW2 As Double Dim myFa As Variant Dim lngIndex As Long Cancel = True '===============画像選択 myF = Application.GetOpenFilename _ ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , MultiSelect:=True) If IsArray(myF) = False Then MsgBox "画像を選択してください(終了)" Exit Sub End If
For Each mySp In ActiveSheet.Shapes myAD1 = mySp.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySp.Delete Next
For Each myFa In myF
'===============画像の掃除
'===============画像の貼り付け Set mySp = ActiveSheet.Shapes.AddPicture(Filename:=myFa, LinkToFile:=False, _ SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _ Width:=0, Height:=0) '★ とりあえず 縦横0で。 mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す mySp.ScaleWidth 1, msoTrue '★元のサイズに戻す '===============タテヨコの縮尺を保持
If mySp.Width > Target.Width Then mySp.Width = Target.Width If mySp.Height > Target.Height Then mySp.Height = Target.Height '===============中央へ調整 myHH2 = (Target.Height / 2) - (mySp.Height / 2) myWW2 = (Target.Width / 2) - (mySp.Width / 2) mySp.Top = Target.Offset(lngIndex, 0).Top + myHH2 mySp.Left = Target.Left + myWW2 Set mySp = Nothing Target.Offset(lngIndex, 1) = Dir(myFa) lngIndex = lngIndex + 1
Next myFa End Sub
(デイト ) 2015/04/24(金) 13:44
For Each mySp In ActiveSheet.Shapes myAD1 = mySp.TopLeftCell.MergeArea.Address myAD2 = Target.Address If myAD1 = myAD2 Then mySp.Delete
お願いします。
(ガ−サ) 2015/04/24(金) 14:17
トップに種別が入り、次に番号が入るのでその番号がファイル名なので
すいません何を変更してほしいのかわかりません
トップとは種別とは番号とはなにか
変更して何をやりたいのでしょうか
もう一つですがしんさんのコードを変えましたが
結合したセルの大きさにジャストサイズに張り付けられます。 なのでドラッグで大きさが変わります
元の写真の縦横比を維持しつつ 結合されたセルの中央にしかもできるだけ大きく 貼り付けたいのですが、 だったらβさんのVBAの方でしたがしんさんのでよかったのでしょうか?
(デイト) 2015/04/24(金) 14:53
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.