[[20150419120616]] 『エクセル2010 VBA 画像挿入 』(しん) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『エクセル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


このサイトを見て、エクセル2003で作ったのを投稿します。2007動作OK
割り込みですが、参考にして見たら!

どんな写真でもセルの大きさに合わせると言うことでよろしいですか?
この他にも横幅に合わせ、縦は写真比率や複数の選択セルに合わせるなど作りました。
ブックのサイズが大きくなる問題も分けは分かりませんが、コピペで大丈夫、組み込んで見て下さい。
コードは、以下の通りです。

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


TO (β) さん

 そうですよね。コードを追加します。

 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


TO (β) さん

 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

皆さん、どうもありがとうございます。
たくさんのコードを書いていただき、一行一行意味を理解しようと
数日がたってしまいました。
やりたかったことはできました。
いろんなコードの書き方がありびっくりです。
道はいろいろあるんですね。
これから私もVBAを勉強してみたいと思いました。
今後ともよろしくお願いいたします。
(しん) 2015/04/23(木) 00:28

初歩的な質問です。
画像は貼り付けはできますけど、その画像のファイル名を特定のセルに表示させるコ−ドを
ご教授お願いします。

2010エクセルです。
(ガ−サ) 2015/04/24(金) 11:08


koさんのコードのままで取得するなら
Range("B2") = Dir(IPicture)
で取得できる。
(デイト ) 2015/04/24(金) 11:31

(しん)さんのコ−ドでお願いします。
追加でお願いします。
シ−ト上に複数枚写真を貼り付け、その都度特定のセルにファイル名を表示を行いた
(ガ−サ) 2015/04/24(金) 11:51

 >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.