[[20120313090248]] 『マクロを使って写真挿入』(naoki)  ページの最後に飛ぶ

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

 

『マクロを使って写真挿入』(naoki)
[Excel2010]

1、Excel2010で、セルをダブルクリックして、写真があるフォルダを開き、画像データ(JPEG)をセルの大きさに合わせ挿入しています。(工事写真を整理してます)

2、挿入元のフォルダ名を変更したり、画像データを削除しても写真が表示出来るようにしたい。

 上の2点を解決出来るマクロの組み方を教えてください。 
マクロ初心者です。 

?@ネット上で見つけたコードで、マクロを組みました。下記の通りです。

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Excel.Range, Cancel As Boolean)

    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.Pictures.Insert(myF)

    '===============タテヨコの縮尺を保持
    myHH = Target.Height / mySP.Height
    myWW = Target.Width / mySP.Width
    If myHH > myWW Then
        mySP.Height = mySP.Height * myWW
        mySP.Width = Target.Width
    Else
        mySP.Height = Target.Height
        mySP.Width = mySP.Width * myHH
    End If

    '===============中央へ調整
    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

?Aしかし、画像挿入元のフォルダ名を変更したり、画像データを削除すると「リンクされたイメージを表示できません。ファイルが移動または削除されたか、名前が変更された可能性があります。リンクに正しいファイル名と場所が指定されていることを確認してください。」とのメッセージが表示されてしまいます。

?Aの問題を解決するために、?@のマクロをどのように書き換えたらよいのでしょうか?

解決できず困っています。
どなたか、ご教示頂けると大変助かります。
よろしくお願いいたします。


 Pictures.Insert、2003まではイメージの貼付けだったけど、2007からは、(MSが勝手に)リンク貼付けになったね。
だから、質問のように困る人がたくさん出てくる。

 しょうがないので ActiveSheet.Shapes.AddShape を使うか、
あるいは、Pictures.Insert で挿入した図をコピーしてペースト。その上で、前の図は削除。

 「Pictures.Insert リンク」あたりで検索すると、いろいろ出ているよ。

 (ぶらっと)

ぶらっとさん
ありがとうございます。

「Pictures.Insert で挿入した図をコピーしてペースト。その上で、前の図は削除。」

というのを試してみましたが、画像挿入元のフォルダを削除したら、同じ現象でした。

いろいろ調べてみても、初心者のため、応用がききません。

ActiveSheet.Shapes.AddShape を
どのようにコードに組み込んだらよいか
教えていただけないでしょうか?

よろしくお願いします。

(naoki)


 まず、ごめん!!
画像ファイルを読み込んで貼り付けるんだったね(あたりまえだけど)
この場合は、Shapes.AddPicTureを使って。
最近、ちょうど、このテーマにマッチしたQ/Aがあったので、それを紹介すればいいんだけどURLを忘れた。
なので、MSが本件について、「偉そうに説明」しているページを紹介。
コード案も出ているので、これでがんばってみて。
http://support.microsoft.com/kb/2396509/ja
 どうしても、壁にぶつかったら、またSOS出してくれたら、めんどくさがらずに自分でコードを書いてアップするので。

 追記)へたなコードをアップするより以下のほうがわかりやすいかな。
http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi?print+201111/11110054.txt

 (ぶらっと)

ぶらっとさん

ありがとうございます。

参考にして勉強してみます。

行き詰った時は、またよろしくお願いします。

(naoki)


ぶらっとさん

いろいろ参考にさせていただきましたが、

根本的なコードの仕組みが分からない為、

Shapes.AddPicTureの使い方がわからず、
 

応用が出来ません。申し訳ありません。
 

SOSを出させていただきます。

最初にも書きましたが、もう一度、目的を整理させて頂きます。

?@結合したセルをダブルクリックすると、写真データがあるフォルダを開き、
 画像データ(JPEG)を選択すると、セルの大きさに合わせ挿入してくれる。

?Aなおかつ、リンク貼り付けではない貼り付けにしたい。
※現在は上にあるコード(リンク貼り付けになってしまう)を使っています。

お手数ですが、上記を満たすコードを教えて頂きたいと思います。

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

(naoki)


 それでは以下に。
 AddShapeの特性を活かし、最初から縦横サイズを指定する方法もあるけど、
 手を抜いて?既存の処理をできるだけ有効に使うコードにしてある。

 なお、
・変数は全て規定すべし。
 モジュールの先頭にOption Explicit を書くくせをつけよう。
 VBE画面のツール->オプション の編集タブで変数必須を設定しておけば、自動的に付加される。
・縦横比率の処理のところは、シェープのプロパティの初期値が「縦横比率の維持」となっているので
 それを利用して、すっきりしたものにしてある。

 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

    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

 (ぶらっと)

 ぶらっとさん

 ありがとうございました。
 私の悩んでいたことが解決することができました。
 詳しいコードの意味はよくわかりませんが、今後学習してみます。
 今回、初めてこのような場所で、質問をさせていただきましたが、
 こんなに早く、親切に教えていただき、大変感謝いたします。
 改めてありがとうございました。

 (naoki)

便乗質問で申し訳ありません。

ぷらっとさまの構文で更に特定のセルのみに対して有効にするにはどう記述すればいいのでしょうか

(かつみ)


 「特定のセル」は、具体的にどの様に定義しますか?

 A1,A12,A13,B8,・・・の様にランダムに?
 A3,A6,A9,B3,B6,B9, ・・・の様に規則的に飛び飛びに?
 A1:B10・・・の様に、ある一定の範囲?

 基本的には、ダブルクリックされたセルが 特定のセルに一致するか確認し
 処理を分岐することになると思います。

 たとえば
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    ◆ここに
    ◆Dim myF As Variant から Dim myWW2 As Double
    ◆を張り付ける
    If Not Intersect(Range("A1:B10"), Target) Is Nothing Then
        ★
        ★ここに
        ★Cancel = True から Set mySp = Nothing
        ★のコードを張り付ける
        ★
    End If
End Sub

 この様にしておけば、A1:B10内のセルがダブルクリックされた時にだけ
 ★に貼りつけたコードが実行されます。

 (HANA)


すいません。
ダブルクリックではなく、標準モジュールから
実行するには、どういう記述にすれば
よいでしょうか?

選択されたセルに画像を挿入としたいのですが
Targetの変数が上手く指定できず
オブジェクトがありませんとなります。

Msgbox Target.addressでみると
RangeなのでTarget.leftと
Target.topさえ指定できれば
解決出来ると思うのですが
よろしくお願いいたします


上を書いたものですが、すいません初歩的なミスをしていました。

下記で考えていた通りの任意のセルに画像挿入を作成できました。

Sub 画像挿入()

    Application.ScreenUpdating = False

    Dim ω As Variant, π As Object, χ1 As String, χ2 As String, φ_h As Double
    Dim φ_w As Double, ρ As Range, г_h As Single, г_w As Single

    Set ρ = Selection

    ω = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)

    If ω = False Then Exit Sub

    For Each π In ActiveSheet.Shapes
        χ1 = π.TopLeftCell.MergeArea.Address
        χ2 = ρ.Address
        If χ1 = χ2 Then π.Delete
    Next

    Set π = ActiveSheet.Shapes.AddPicture(Filename:=ω, LinkToFile:=False, _
        SaveWithDocument:=True, Left:=ρ.Left, Top:=ρ.Top, Width:=0, Height:=0)

    π.ScaleHeight 1, msoTrue
    π.ScaleWidth 1, msoTrue

    г_h = ρ.Height / π.Height
    г_w = ρ.Width / π.Width

        If г_h > г_w Then
                 π.Height = ρ.Height / г_w * 0.95
                 π.Width = ρ.Width * 0.95
        ElseIf г_h < г_w Then
                 π.Height = ρ.Height * 0.95
        End If

    φ_h = (ρ.Height / 2) - (π.Height / 2)
    φ_w = (ρ.Width / 2) - (π.Width / 2)
    π.Top = ρ.Top + φ_h
    π.Left = ρ.Left + φ_w

    Set π = Nothing

    Application.ScreenUpdating = True
End Sub

(wiki)


naoki様が、ネットで拾ったと仰っているコードを、
私も利用していたのですが、
貼り付けた画像をメール等で送ると相手が見れなく
なってしまう(私のエクセルが2003⇒2010になった為)
現象に悩んでいたところ、このページに辿りつきました。

そこでぷらっと様のコードを拝借したのですが、
どうしても統合セルの大きさに合わせて、写真の縦横比が変わってしまいます。

元写真の縦横比を保持しつつ、写真枠いっぱいに収まるようにするには、
(naoki様がネットで拾ったコードだとそうなります)
どのようにしたら宜しいですか?

VBAとマクロの違いも判らないような初心者ですが、
お教え頂けると大変有難く存じます。

(にこ) 2013/12/26(木) 17:59


 >'===============タテヨコの縮尺を保持
 の一つ上の行にでも
    mySp.LockAspectRatio = msoTrue '★縦横比を固定する
 を入れてみるとどうですか?
  
(HANA) 2013/12/27(金) 08:52

初めて質問させていただきます。

naoki様が、ネットで拾ったと仰っているコードを、私も利用しておりました。

仕事上、縦撮り写真が多く、写真を縦撮り状態でプレビュー画面で見れるよう保存しています。

ぷらっと様、HANA様のコードを併せて使わせていただいたところ、
縦撮りで撮影した写真が横向きで張り付けられてしまいました。

HANA様のコードを入れなかった場合は、縦撮り写真が縦のままで
(ただし、写真の縦横比は変わってしまいます)貼り付けできます。
横撮り写真は、問題なく貼り付けできます。

縦撮りで保存した写真を縦撮りのまま、元写真の縦横比を保持しつつ、写真枠(結合したセル内)いっぱいに収まるようにするには、 どのようにしたら宜しいですか?

大変申し訳ありませんが、ご教授の程、よろしくお願いします。
(ばーばもじゃ) 2016/06/27(月) 17:25


 ずいぶん古いトピなので、新規に質問したほうが、皆さんから回答がアップされやすいとは思いますが。

 >>ぷらっと様、HANA様のコードを併せて使わせていただいたところ、 
 >>縦撮りで撮影した写真が横向きで張り付けられてしまいました。 
 >>HANA様のコードを入れなかった場合は、縦撮り写真が縦のままで 
 >>(ただし、写真の縦横比は変わってしまいます)貼り付けできます。 
 >>横撮り写真は、問題なく貼り付けできます。 

 今はなき(?? 本人は、いたって健康に過ごしていますので、勝手に殺しちゃいけませんが)友人のぶらっとが書いたコード、
 縦横比率のところが、ちょっと不備がありますね。

 で、HANAさんのコードとおっしゃっていますが、ぶらっとのコードで、セル特定をするところだけを追加しておられます。

 なので、Pictures.Insert と Shapes.AddPicture の違いで 縦の写真が横になる、横の写真が縦になる ということなんでしょうか?
 ちょっと考えられないのですけど??

 いずれにしても、以下ではいかがですか。

    myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If myF <> False Then
        With ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
            SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
            Width:=-1, Height:=-1)      '-1 元の大きさで貼り付け
            '===============タテヨコの縮尺を保持して拡大または縮小
            .LockAspectRatio = True     '縦横比率の維持(念のため)
            .Width = Target.Width
            If .Height > Target.Height Then .Height = Target.Height
            '===============中央へ調整
            .Top = Target.Top + Target.Height / 2 - .Height / 2
            .Left = Target.Left + Target.Width / 2 - .Width / 2
        End With
    End If

(β) 2016/06/27(月) 18:00


 追加で。後学のため教えてください。

 >>仕事上、縦撮り写真が多く、写真を縦撮り状態でプレビュー画面で見れるよう保存しています。

 つまり、縦か横かというより、実態は 横 なんですね?
 で、プレビューで【無理やり】横にして表示しているんですね?

 であれば、実態は 横 ですから、横で挿入されても不思議ではないです。
 ただ、Picture.Insert だったら、そういうものは 縦で挿入されるのでしょうか?
 (試してみればわかるんでしょうけど、手元に、そのような画像がないもので)
(β) 2016/06/27(月) 18:07

β様

返信ありがとうございます。
色々と、マクロの組み方があるのだなー、これから一生懸命勉強しなければと思うアラフォーです。

「つまり、縦か横かというより、実態は 横 なんですね?」
「プレビューで【無理やり】横にして表示しているんですね?」

という質問でしたが、当方、Win10 Excel2007で仕事をしております。
写真を取り込んだ際、縦撮り撮影したものは、プレビュー画面でも、フォトでも、縦撮りで見ることができます。
フォトにてファイル情報を確認すると、
横撮りは サイズ1280×960 
縦撮りは サイズ960×1280 
となっております。

本日は、今までのマクロでも、縦撮りした写真が横で貼り付けられるという状況だったので(原因は不明です)、
「90度回転して貼り付ける(.Rotation = 90#)」
「高さを80mmにする(.Height = 240)」
という形にしました。

 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
    Cancel = True
    '===============画像選択
  myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If myF <> False Then
        With ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
            SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
            Width:=-1, Height:=-1)      '-1 元の大きさで貼り付け
            .Rotation = 90#
            '===============タテヨコの縮尺を保持して拡大または縮小
            .LockAspectRatio = True     '縦横比率の維持(念のため)
            If .Width > Target.Width Then .Width = Target.Width
            .Height = 240

            '===============中央へ調整
            .Top = Target.Top + Target.Height / 2 - .Height / 2
            .Left = Target.Left + Target.Width / 2 - .Width / 2
        End With
    End If
 End Sub
 
こうしたところ、貼り付けた写真が、指定したセルの中央ではなく、ちょっとずれた場所に貼りついてしまいました。

色々と試したのですが、結合したセルの中央部に貼り付けることができませんでした。

何かしら、アドバイスを頂きたくコメントを入れました。
よろしくお願いいたします。

追伸:
どうして縦撮りにこだわるのか不思議に思われるかもしれないので、当方の仕事内容について報告します。

当方、地質調査業(ボーリング屋さんです)の仕事に従事しております。
この業界は、フィルムカメラの時代から、縦撮りが基本(やぐらなど、背が高いもの等を撮影するので)となっております(最近は、横撮り写真も見受けられますが)。

写真用アルバムは、フィルムカメラ時代の名残で、貼り付ける写真は、E版(120mm×80mm)です。
現在は、Excelで 縦120mm×横80mmとなるようセルを結合し、この枠内にあうよう、横80mmを基準に貼り付けてます。ちなみに、A4サイズの用紙に4枚(2枚×2枚)で貼るようにしております。
(ばーばもじゃ) 2016/06/28(火) 17:23


 >>これから一生懸命勉強しなければと思うアラフォーです。

 はい。人生、いつまでも勉強だと感じている、アラセブンのβです。
 で、これはβが勉強不足なんでしょうけど、βの環境では、たとえばスマホで撮影した写真、PCに取り込みますと
 縦撮りは縦撮りで、横撮りは横撮りで保存されますので 何もしなくても縦撮りは縦に、横撮りは横になって貼りつきます。

 今、お使いのカメラは、専門的なものでしょうから、スマホのようなものではないのですね。
 なので、縦に撮影したものでも、カメラから見れば、横向きの変な写真になるわけですね?

 通常、そういった場合、PCに取り込んだ後、PCにおまけで付属している画像ソフトや専門の画像そふとで
 縦横逆転して、保存しなおすのではないですか?
 (プレビューで回転して扱うだけではなく本当に回転させて保存する)
 そうしておけば、【カメラ的】には横だった写真が データ的に、【ちゃんとした縦】のものになります。

 一方、エクセルに話を戻しますと、写真もエクセル上ではシェープです。

 新規ブックのシートに 1つだけ 横長の四角形を配置してください。

 で、以下を実行してください。

 Sub Test()
    With ActiveSheet.Shapes(1)
        MsgBox "W:" & .Width & vbLf & "H:" & .Height
    End With
 End Sub

 当然 W が H より大きいですね。

 次に、この四角形をつまんで、90度 回転させて 縦長にしてください。
 そうした上で、もう一度、↑のコードを実行してください。
 見た目は W は H より小さいですよね。でも結果は?

 シート上に取り込んだシェープは、取り込んだものを、ずっと記憶します。
 回転は、あくまで【見た目の幻】です。忍者の【空蝉の術】のようなもので、実態は回転前の場所に
 回転前の形状で【ひっそり、闇にまぎれて潜んでいます】

 ですから、【本当は横】のものを 回転させたうえで、大きさ調節や場所調節をしようとすれば
 そのことを加味した、煩雑な値の指定を行うか、あるいは 元画像そのものを適切な向きに回転させたうえで保存して
 エクセルでは、それを使う。

 いずれかだと思いますし、後者をおすすめします。

(β) 2016/06/28(火) 21:09


 コメントした、【幻の位置】の調整で、セルの中心に合わせてみました。
 今回は 90度回転ということが決まっていますので決め打ちの計算でもいいのですが
 手元に、回転図形の見た目の座標を取得する自作プロシジャがありますので、それを利用します。

 エクセルには、シート上のポイント値について、自動調整する機能がありますので
 セル枠にぴったりではなく、若干縮小されるかもしれません。

 (頭の中で90度、右回転させれば、元のあのいちはここ、このいちはあっち と 考えながら書きましたので
  位置が変になればごめんなさい。自信度 60%ぐらいです)

 Private Type xy
    x As Double
    y As Double
 End Type

 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 pic As Shape
    Dim dTL As xy   '回転後の架空の左上
    Dim dTR As xy   '回転後の架空の右上
    Dim dBL As xy   '回転後の架空の左下
    Dim dBR As xy   '回転後の架空の右上
    Dim dCT As xy   '回転後の架空の中心

    Cancel = True
    '===============画像選択
    myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If myF <> False Then
        Set pic = ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
            SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
            Width:=-1, Height:=-1)      '-1 元の大きさで貼り付け
        pic.Rotation = 90#
        '===============タテヨコの縮尺を保持して拡大または縮小
        pic.LockAspectRatio = True     '縦横比率の維持(念のため)
        If pic.Height > Target.Width Then pic.Height = Target.Width
        If pic.Width > Target.Height Then pic.Width = Target.Height
        pic.Left = Target.Left
        pic.Top = Target.Top
        '===============回転後の架空の中心を求める
        dTL = getPoint(pic, pic.Left, pic.Top)
        dTR = getPoint(pic, pic.Left + pic.Width, pic.Top)
        dBR = getPoint(pic, pic.Left + pic.Width, pic.Top + pic.Height)
        dBL = getPoint(pic, pic.Left, pic.Top + pic.Height)
        dCT.x = (dBR.x + dTL.x) / 2
        dCT.y = (dBL.y + dBR.y) / 2
        '===============中央へ調整
        pic.IncrementLeft Target.Left + Target.Width / 2 - dCT.x
        pic.IncrementTop Target.Top + Target.Height / 2 - dCT.y
    End If
 End Sub

 Private Function getPoint(sp As Shape, ByVal x As Double, ByVal y As Double) As xy
    Dim sn As Double
    Dim cs As Double
    Dim cX As Double
    Dim cY As Long
    Dim angle As Double

    angle = sp.Rotation * WorksheetFunction.Pi() / 180    'ラジアン角に変換
    sn = Sin(angle) 'サイン
    cs = Cos(angle) 'コサイン

    With sp
        cX = .Left + .Width / 2
        cY = .Top + .Height / 2
    End With

    getPoint.x = (x - cX) * cs - (y - cY) * sn + cX
    getPoint.y = (x - cX) * sn + (y - cY) * cs + cY

End Function

(β) 2016/06/29(水) 07:50


横から失礼します。
下記は、こちらのページを参考にしたのですが、高さをセルに合わせるところがうまくいきません。
縦横比は固定したいので、縦だけをセルの高さに合わせて貼りつけたいと思っています。
対象セルの行の高さは縦:297×横:67.04です。
ご教授お願いします。

 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
    If Not Intersect(Range("B39:I60"), Target) Is Nothing Then
    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:=Target.Width, Height:=Target.Height)    '★ とりあえず 縦横0で。
    mySp.ScaleHeight 1, msoTrue '★元のサイズに戻す
    mySp.ScaleWidth 1, msoTrue  '★元のサイズに戻す
    mySp.LockAspectRatio = msoTrue '★縦横比を固定する
    '===============タテヨコの縮尺を保持
    If mySp.Width > Target.Width Then mySp.Width = Target.Width
    If mySp.Height > Target.Height Then mySp.Height = Target.Height
    Set mySp = Nothing
    End If
 End Sub
(せみ) 2016/08/01(月) 10:23

≪追加≫
使用OSはwindows7、EXCELのバージョンは2016です。
(せみ) 2016/08/01(月) 10:27

 要件は、セルの中央配置も不要、横長、縦長であろうと、セルの左上隅に縦のみセルの高さにあわえて縦横比率を維持した調整を行いたいということですか?
 で、うまくいかないというのが、どこが、どうなるべきなのに、どうなってしまうのですか?

(β) 2016/08/01(月) 15:09


 もう1つ。

 >>縦:297×横:67.04です

 それぞれの数値の単位は? 縦はポイント値ですかね?
 横は?

(β) 2016/08/01(月) 15:11


 連投失礼。

 >>こちらのページを参考にしたのですが

 ということですけど、(β) 2016/06/27(月) 18:00 で提示したコードを参考にしてみるとどうなりますか?

(β) 2016/08/01(月) 15:21


β様、お返事ありがとうございます。

 >>要件は、セルの中央配置も不要、横長、縦長であろうと、セルの左上隅に縦のみセルの高さにあわえて縦横比率を維持した調整を行いたいということですか?
 →そのとおりです。
 セルの大きさより大きい写真はセルの高さに調整されますが、小さい写真の場合、セルに合わせて高さが変わりません。

 >>それぞれの数値の単位は? 縦はポイント値ですかね?横は?
 →ポイント値、だと思います。
 縦と横の数字は、エクセルの行の高さと列の幅を足したものです。

 >>(β) 2016/06/27(月) 18:00 で提示したコードを参考にしてみるとどうなりますか?
 →残念ながら変わりませんでした。
 セルより小さいセルは元の大きさで貼りつけられました。
(せみ) 2016/08/02(火) 15:04

 不思議ですねぇ。

 念のため、(β) 2016/06/27(月) 18:00 の提示コードをそちらの要件に合わせると

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim myF As Variant

    Cancel = True

    myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If myF <> False Then
        With ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
            SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
            Width:=-1, Height:=-1)      '-1 元の大きさで貼り付け
            '===============タテヨコの縮尺を保持して拡大または縮小
            .LockAspectRatio = True     '縦横比率の維持(念のため)
            .Height = Target.Height
        End With
    End If

 End Sub

 こんな感じになりますけど、これではだめということですか? 

(β) 2016/08/02(火) 16:04


β様
(β) 2016/08/02(火) 16:04のコードに、マクロが有効になるセルの指定("B39:I60")を追加して試したところ、思い通りの動きになりました。
これでかなりの時間短縮になります。
マクロとVBAの違いも分からないド素人ですが、いずれきちんと勉強しようと思います。
この度はありがとうございました。
(せみ) 2016/08/03(水) 13:37

β様
うまくいったと思いましたが、マクロが有効になるセルを指定する部分がうまくいかないので教えてください。
下記のコードだとどのセルをダブルクリックしても画像選択画面が開いてしまいます。
B39:I60の範囲でのみ有効にするにはどう修正すればよろしいでしょうか?

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Dim myF As Variant
    Cancel = True
    If Not Intersect(Range("B39:I60"), Target) Is Nothing Then
    Cancel = True
    End If
    myF = Application.GetOpenFilename _
           ("jpg bmp tif png gif,*.jpg;*.bmp;*.tif;*.png;*.gif", , "画像の選択", , False)
    If myF <> False Then
        With ActiveSheet.Shapes.AddPicture(Filename:=myF, LinkToFile:=False, _
            SaveWithDocument:=True, Left:=Target.Left, Top:=Target.Top, _
            Width:=-1, Height:=-1)
            .LockAspectRatio = True
            .Height = Target.Height
        End With
    End If
 End Sub
(せみ) 2016/08/03(水) 14:21

    If Not Intersect(Range("B39:I60"), Target) Is Nothing Then
         Cancel = True
    End If

 これを

    If Intersect(Range("B39:I60"), Target) Is Nothing Then Exit SUb

 にしてためしてください。

(β) 2016/08/03(水) 15:57


β様
画像選択画面は開かなくなりましたが、文字を入力したいセルをダブルクリックしてもマウスカーソルが表示されません。
数式バーに入力すれば済むのですが、できればセルのダブルクリックで入力したいです。
(せみ) 2016/08/03(水) 17:03

 >>文字を入力したいセルをダブルクリックしてもマウスカーソルが表示されません。 

 それは、そちらのコードで、プロシジャの先頭で、無条件に Cancel = True をいれているからです。

 Cancel = True を If Intersect(Range("B39:I60"), Target) Is Nothing Then Exit SUb の下に移動しましょう。

(β) 2016/08/03(水) 17:06


β様
うまくいきました!
今度こそ、ありがとうございました!
(せみ) 2016/08/03(水) 17:15

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.