[[20151106133015]]　『画像貼り付けコードの応用』（もやし）　ページの最後に飛ぶ

『画像貼り付けコードの応用』（もやし）

セルをダブルクリックすると指定のフォルダ立ち上げ、
そこにある画像ファイルをクリックすると、
セル範囲に合せて画像を貼り付けるコードを色々調べて作ったのですが、
シート上に、画像を貼り付ける箇所が沢山あるため、
箇所毎にコード追加したのでは手間ですので、
１つのコードで複数セルを選択出来ないものでしょうか？
宜しくお願いします。

例として、シート１に、20箇所貼り付ける場所があるとします。
C6,C12,C18,C24,C30,C36,C42,C48,C54,C60
Z6,Z12,Z18,Z24,Z30,Z36,Z42,Z48,Z54,Z60

現状のコード
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Const myFolder As String = "D:\画像ファイル"
Dim fname
Dim currentfolder As String
Dim CELL_WIDTH As Integer
Dim CELL_HEIGHT As Integer
Dim CELL_TOP As Integer
Dim CELL_LEFT As Integer
Dim CELL_PERCENTAGE As Single
Dim PHOTO_WIDTH As Integer
Dim PHOTO_HEIGHT As Integer
Dim PHOTO_TOP As Integer
Dim PHOTO_LEFT As Integer
Dim PHOTO_PERCENTAGE As Single
Dim PHOTO_FILE_NAME As String
Dim myPHOTO As Object

    currentfolder = CurDir

    ChDrive myFolder
    ChDir myFolder

  If Intersect(Target, Range("C6")) Is Nothing Then Exit Sub

  Cancel = True

    fname = Application.GetOpenFilename("画像 Files (*.jpg), *.jpg")
    If TypeName(fname) = "Boolean" Then

       ChDrive currentfolder
       ChDir currentfolder
       Exit Sub
    End If

    CELL_WIDTH = Selection.Width
    CELL_HEIGHT = Selection.Height
    CELL_TOP = Selection.Top
    CELL_LEFT = Selection.Left
    CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH
    Set myPHOTO = ActiveSheet.Pictures.Insert(fname)

    PHOTO_WIDTH = myPHOTO.Width
    PHOTO_HEIGHT = myPHOTO.Height
    PHOTO_TOP = myPHOTO.Top
    PHOTO_LEFT = myPHOTO.Left
    PHOTO_PERCENTAGE = PHOTO_HEIGHT / PHOTO_WIDTH

    If CELL_PERCENTAGE > PHOTO_PERCENTAGE Then
        myPHOTO.Width = CELL_WIDTH * 1#
        myPHOTO.Height = CELL_WIDTH * PHOTO_PERCENTAGE * 0.95
        myPHOTO.Top = CELL_TOP + _
            (CELL_HEIGHT - (CELL_WIDTH * PHOTO_PERCENTAGE * 0.95)) / 2
        myPHOTO.Left = CELL_LEFT + (CELL_WIDTH * 0.025)
    Else
        myPHOTO.Width = (CELL_HEIGHT / PHOTO_PERCENTAGE) * 1#
        myPHOTO.Height = CELL_HEIGHT * 0.95
        myPHOTO.Top = CELL_TOP + (CELL_HEIGHT * 0.025)
        myPHOTO.Left = CELL_LEFT + _
            (CELL_WIDTH - ((CELL_HEIGHT / PHOTO_PERCENTAGE) * 0.95)) / 2
    End If

    Set myPHOTO = Nothing

End Sub

コードの不備はご了承ください。
コードの、
If Intersect(Target, Range("C6")) Is Nothing Then Exit Sub
のRange内を変更すると思って、Unionとか試したのですが出来ませんでした。

＜使用アプリ：Excel2000、使用 OS：WindowsXP ＞

ダブルクリックだと1セルしか選択できないので、右クリックで動作させてはいかがでしょうか？
Worksheet_BeforeRightClick に変えるだけです。
（???） 2015/11/06(金) 15:27

Worksheet_BeforeRightClick
に変えてみましたが、複数のセルでは駄目でした。
多分、私がよく理解できてないだけだと思いますが、
出来れば左クリックで動作させたいです。

ダブルクリックだと１セルしか選択できないというのは、
今のコードに問題があるからでしょうか？
別の方法では可能なのでしょうか？？宜しくお願いします。
（もやし） 2015/11/06(金) 16:32

 どちらでしょう？

 (1) ひとつの画像を対象セルすべてに貼り付ける
 (2) 対象セルのどれかひとつのセルで(ダブル or 右)クリックした際に作動させる

 (2)の場合
 If Intersect(Target, Range("C6")) Is Nothing Then Exit Sub
 ここの"C6"を、
 "C6,C12,C18,C24,C30,C36,C42,C48,C54,C60,Z6,Z12,Z18,Z24,Z30,Z36,Z42,Z48,Z54,Z60"
に変更

 まあ長いので、string型の変数にいれてもいいんでないかと…

（＿＿＿） 2015/11/06(金) 17:02

こんにちは

簡単に変えるなら、

    If Intersect(Target, Range("C6")) Is Nothing Then Exit Sub
を
    If InStr(1, "C6,C12,C18,C24,C30,C36,C42,C48,C54,C60," & _
                    "Z6,Z12,Z18,Z24,Z30,Z36,Z42,Z48,Z54,Z60", _
        Target.Address(0, 0, xlA1)) = 0 Then Exit Sub

でしょうか？

後続のコードは読んでいません。

（ウッシ） 2015/11/06(金) 17:04

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
'ctrlキー等で複数セルを選択してから右クリック

Const myFolder As String = "D:\画像ファイル"
Dim fname
Dim currentfolder As String
Dim CELL_WIDTH As Integer
Dim CELL_HEIGHT As Integer
Dim CELL_TOP As Integer
Dim CELL_LEFT As Integer
Dim CELL_PERCENTAGE As Single
Dim PHOTO_WIDTH As Integer
Dim PHOTO_HEIGHT As Integer
Dim PHOTO_TOP As Integer
Dim PHOTO_LEFT As Integer
Dim PHOTO_PERCENTAGE As Single
Dim PHOTO_FILE_NAME As String
Dim myPHOTO As Object

    currentfolder = CurDir

    ChDrive myFolder
    ChDir myFolder

    fname = Application.GetOpenFilename("画像 Files (*.jpg), *.jpg")
    If TypeName(fname) = "Boolean" Then

       ChDrive currentfolder
       ChDir currentfolder
       Exit Sub
    End If

For Each cl In Selection

picpaste cl, fname

Next cl

End Sub

Sub picpaste(arg1, arg2)

    CELL_WIDTH = arg1.Width
    CELL_HEIGHT = arg1.Height
    CELL_TOP = arg1.Top
    CELL_LEFT = arg1.Left
    CELL_PERCENTAGE = CELL_HEIGHT / CELL_WIDTH
    Set myPHOTO = ActiveSheet.Pictures.Insert(arg2)

    PHOTO_WIDTH = myPHOTO.Width
    PHOTO_HEIGHT = myPHOTO.Height
    PHOTO_TOP = myPHOTO.Top
    PHOTO_LEFT = myPHOTO.Left
    PHOTO_PERCENTAGE = PHOTO_HEIGHT / PHOTO_WIDTH

    If CELL_PERCENTAGE > PHOTO_PERCENTAGE Then
        myPHOTO.Width = CELL_WIDTH * 1#
        myPHOTO.Height = CELL_WIDTH * PHOTO_PERCENTAGE * 0.95
        myPHOTO.Top = CELL_TOP + _
            (CELL_HEIGHT - (CELL_WIDTH * PHOTO_PERCENTAGE * 0.95)) / 2
        myPHOTO.Left = CELL_LEFT + (CELL_WIDTH * 0.025)
    Else
        myPHOTO.Width = (CELL_HEIGHT / PHOTO_PERCENTAGE) * 1#
        myPHOTO.Height = CELL_HEIGHT * 0.95
        myPHOTO.Top = CELL_TOP + (CELL_HEIGHT * 0.025)
        myPHOTO.Left = CELL_LEFT + _
            (CELL_WIDTH - ((CELL_HEIGHT / PHOTO_PERCENTAGE) * 0.95)) / 2
    End If

End Sub

（mm） 2015/11/06(金) 17:10

 要件として、複数セルに同じ画像を一挙に入れたいのか、それぞれのセルに異なる画像をいれていきたいのか
 そのあたりの要件が不明ですが、そこのところは、すでに回答いただいている皆さんとすり合わせながら
 解決に向かっていただくとして、セット要件の

 ・画像の縦横比率を維持しながら、指定セル領域内で最大（95%) になるように大きさを調整した上で指定領域の中心に配置する

 というポイントのみでコメントします。

 指定領域の縦横比率や画像の縦横比率を取得してそれらを比較しながら処理しておられますが、そうしなくても、以下のような単純なコードで実現できると思います。
 以下のコードは、ダブルクリックされたセルがどこであれ、そのセル領域に、セット要件通りの画像配置を行います。

 Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
    Const myFolder As String = "D:\画像ファイル"
    Dim fname
    Dim currentfolder As String
    Dim CELL_WIDTH As Integer
    Dim CELL_HEIGHT As Integer
    Dim CELL_TOP As Integer
    Dim CELL_LEFT As Integer
    Dim CELL_PERCENTAGE As Single
    Dim myPHOTO As Object

    currentfolder = CurDir

    ChDrive myFolder
    ChDir myFolder

    Cancel = True

    fname = Application.GetOpenFilename("画像 Files (*.jpg), *.jpg")
    If TypeName(fname) <> "Boolean" Then

        CELL_WIDTH = Target.Width
        CELL_HEIGHT = Target.Height
        CELL_TOP = Target.Top
        CELL_LEFT = Target.Left

        Set myPHOTO = ActiveSheet.Pictures.Insert(fname)

        myPHOTO.ShapeRange.LockAspectRatio = msoTrue '念のため

        myPHOTO.Width = CELL_WIDTH * 0.95
        If myPHOTO.Height > CELL_HEIGHT * 0.95 Then myPHOTO.Height = CELL_HEIGHT * 0.95
        myPHOTO.Left = CELL_LEFT + CELL_WIDTH / 2 - myPHOTO.Width / 2
        myPHOTO.Top = CELL_TOP + CELL_HEIGHT / 2 - myPHOTO.Height / 2

    End If

    ChDrive currentfolder
    ChDir currentfolder

    Set myPHOTO = Nothing

 End Sub

（β） 2015/11/07(土) 12:32

みなさまコメントありがとうございます。

説明不足申し訳ございません。
やりたい動作として、
対象セルのどれかひとつのセルでダブルクリック（左クリック）した際に作動させる
事です。

まず（＿＿＿）さんの方法で試してみたら、
思い通りの動作が出来ました。ありがとうございます。
しかし、貼り付け箇所が30箇所程度でしたら大丈夫なのですが、
シートによって貼り付ける箇所が60箇所くらいあり、
そのシートでは、（＿＿＿）さんの方法ではエラーになりました。

それでウッシさんの方法で試してみたのですが、
上手く動作しませんでした。（エラーもでません）

対象セルが多いとダメなんでしょうか？

また、大変申し訳ございませんが、
ｍｍさんのコードは右クリックとありましたので、まだ試しておりません。

βさんにお教え頂いた画像調整はほぼバッチリでした。ありとうございます。

（もやし） 2015/11/08(日) 11:27

いろいろ調べて見たところ、
Rangeで文字数の制限があるのでダメだったみたいでした。
string型の変数に入れて試してみたら何とか完成しました！
ありがとうございました！！
（もやし） 2015/11/08(日) 15:37

コメント返信：

[ 一覧(最新更新順) ]

[[20151106133015]] 『画像貼り付けコードの応用』（もやし） ページの最後に飛ぶ

[[20151106133015]]　『画像貼り付けコードの応用』（もやし）　ページの最後に飛ぶ