[[20100617110410]]　『画像の貼付』（どびー）　ページの最後に飛ぶ

『画像の貼付』（どびー）WindowsXP　Excel2003　です

画像の貼付（挿入）についてご指導お願いします。
画像データをエクセルのシートに挿入してくのですが、
毎日同じ作業を繰り返すので、ボタン（マクロ）ひとつでできないものかと・・・。

シートでセルをひとつづつ選択した順番に、ナンバリングした画像をその順番に貼付していきたいのです。
つまり、Ctrlを押しながらセルを選択した順番に、
かつ、画像データのナンバー順に貼り付けたいのです。

よろしくご指導のほどお願いいたします

[[20100615140805]]　『写真を挿入した時に自動でセルに合うサイズで挿入』（しょうこう）

 参考になりませんでしょうか？
 サイズ以外の部分がほとんど同じ動作をするコードです。
 （ｍｏｍｏ）

他にも調べてみて、一つ下記の方法を見つけました。

 Sub 画像貼付()
 Dim pic As Picture
    Dim crng As Range
    Dim rng As Range
    Dim ele As Variant
    Dim flnm As Variant
    Dim g0 As Long, g1 As Long
    Dim radd() As Variant
    Dim ff As Boolean
    g1 = 0
    flnm = Application.GetOpenFilename(, , "Select picture files", , True)
    If TypeName(flnm) <> "Boolean" Then
       On Error Resume Next
       Set rng = Application.InputBox("ファイル数" & _
                   UBound(flnm) - LBound(flnm) + 1 & _
                   "個)を貼り付けるセル（セル範囲）を指定しください", , , , , , , 8)
       If Err.Number = 0 Then
          g0 = 0
          For Each crng In rng
             Err.Clear
             ff = False
             If g0 = 0 Then ff = True
             If chk_rng(crng, ff) = 0 Then
                Set pic = crng.Parent.Pictures.Insert(flnm(LBound(flnm) + g0))
                If Err.Number = 0 Then
                   With crng.MergeArea
                      pic.Left = .Left
                      pic.Top = .Top
                      pic.Width = .Width
                      pic.Height = .Height
                      pic.Placement = xlMoveAndSize
                      g0 = g0 + 1
                      End With
                Else
                   MsgBox Err.Description
                   Exit For
                   End If
                End If
             Next
          End If

       On Error GoTo 0
       End If
End Sub
Function chk_rng(crng As Range, Optional first As Boolean = False) As Long

    Static radd() As Variant
    Static fcnt As Long
    Dim ans As Variant
    If first = True Then
       Erase radd()
       fcnt = 0
       End If
    If fcnt = 0 Then
       ans = CVErr(1004)
    Else
       ans = Application.Match(crng.MergeArea.Address(, , , True), radd(), 0)
       End If
    chk_rng = 1
    If IsError(ans) Then
       ReDim Preserve radd(1 To fcnt + 1)
       radd(fcnt + 1) = crng.MergeArea.Address(, , , True)
       fcnt = fcnt + 1
       chk_rng = 0
       End If
End Function

が、質問にも書きましたが、

“シートでセルをひとつづつ選択した順番に、画像を選んだその順番に貼付していきたいのです”

上記のコードでは画像が選んだ順とは関係なく並んでしまうのです。

もうあと一息なのですが・・・、お助けください！！

（どびー）

 σ(^o^;)には、難しすぎてわかりませんが、、、
　
 スレを編集無しに一番上に上げているのは、どびーさんでしょうか？
 他の方にも迷惑になりますし、「自分の質問を見て！」って言っているみたいで・・・
　
 もう少し、気長に待ってみましょうよ＾＾
 （キリキ）（〃⌒o⌒)b

 GetOpenFileNameのMultiSelectですとソートされた順番になると思うので
 ファイル選択を選択順にするのでしたらループ内で
 GetOpenFileNameを使って１つづつコレクションなどに追加していくか
 ユーザーフォームなどでListBoxなどにフォルダ内の全てのファイルを表示しておいて
 選択順にChangeイベントでコレクションに追加していくようにしないと難しいと思います。
 （ｍｏｍｏ）

[[20080215151052]]

 ここからの引用ですか？
 >画像を選んだその順番に貼付していきたいのです

 リンクスレッドの最後のコードが仕様を満たしているはずです。
 試してみてください。

 ichinose

ichinoseさま

ありがとうございます。

ユーザーフォームでリストボックスで順番を変えることは上記のコードでできました。

でも、もっと単純な作業で「Ctrlを押しながらの選択順」での貼付というのは、できますでしょうか？

いろいろためしてはみるもののうまくいかず。

追加です。
ユーザーフォームでリストボックスで順番を選択する場合、

画像が格納されているフォルダが　C→Group別→A→File.2→○○→№○　

などとかなり層が厚くなり、リストボックス内に表示できないのです。

ユーザーフォームの幅を広げるにはどのようにすれば・・・

よろしくお願いします。

（どびー）

 >「Ctrlを押しながらの選択順」
 基本的な方法では思いつきませんし、私の想像するやり方もichinoseさんと同じでしたので

 全く検証もしていませんが・・・
 おそらくListViewコントロールやTreeViewコントロールを使って擬似的に
 GetOpenFileNameと同じような事をさせれば出来るかもしれません。

 検証する時間も無いですしコードも結構面倒になりそうなので案だけですみませんが参考になれば。 
 （ｍｏｍｏ）

 >いろいろためしてはみるもののうまくいかず。
 何をしたのかを記述してください。
 TreeViewコントロールを使う方法も考えられますが、ｍｏｍｏさんの記述にもあるように
 FileやFolderのツリーの作成は、大変です。
 ファイル選択ダイアログで一ファイル毎に選択する仕様にしてみては？
 新規ブックにて試してみてください。

 ユーザーフォームを使います。 
 ユーザーフォーム（UserForm1） 
　　コマンドボタン　ファイル選択 
　　リストボックス　選択したファイル名を表示 
　　スピンボタン　　リストボックスのメンバの移動 
　　コマンドボタン　画像貼付セル範囲選択 
　　コマンドボタン　貼付実行

 ・　ファイル選択ボタンクリックでファイル選択ダイアログが表示されます。
   　貼り付ける画像をひとつ選択してください。ＯＫをクリックすると、
     選択ファイルがリストボックスに登録され、再び、ファイル選択ダイアログが表示されます。 
     これを繰り返して、複数ファイルをリストボックスに登録します。
     キャンセルボタンでファイル選択ダイアログが表示が中止されます。

 ・　選択したファイル名がリストボックスに表示されます。　　スピンボタンを使って貼り付ける順序調節してください。　　（リストボックス内のメンバを選択し、スピンボタンをクリックすると　　　メンバが移動します）

 ・　画像貼付セル範囲選択ボタンをクリックしてセル範囲を選択してください。

 ・　貼付実行ボタンクリックで画像の貼り付けを開始します。

 さてコードです。

 ユーザーフォーム（UserForm1）だけを作成してください。

 UserForm1に配置するコントロールは、コードで作成しますから、何も配置しないで下さい。

 UserForm1のモジュールに

 '=============================================================================== 
 Option Explicit 
 Private WithEvents btn_fl_select As MSForms.CommandButton 
 Private WithEvents lst_fl_list As MSForms.ListBox 
 Private WithEvents spn_fl_list_set As MSForms.SpinButton 
 Private WithEvents btn_rg_select As MSForms.CommandButton 
 Private WithEvents btn_paste_exec As MSForms.CommandButton 
 Private lbl_rg_add As MSForms.Label 
 Private Sub btn_fl_select_Click() 
    Dim flnm As Variant
    flnm = ""
    With lst_fl_list
       .Clear
       Do Until TypeName(flnm) = "Boolean"
          flnm = Application.GetOpenFilename(, , "Select one file", , False)
          If TypeName(flnm) <> "Boolean" Then
             .AddItem flnm
          End If
       Loop
       .Height = 252
       .Visible = False
       DoEvents
       .Visible = True
       .SetFocus
    End With
 End Sub
 Private Sub btn_rg_select_Click() 
    On Error Resume Next
    Dim rng As Range
    lbl_rg_add.Caption = ""
    Me.Hide
    Set rng = Application.InputBox("ファイル数 (" & _
                    lst_fl_list.ListCount & _
                   " 個)を貼り付けるセル（セル範囲）を指定しください", , , , , , , 8)
    If Err.Number = 0 Then
       lbl_rg_add.Caption = rng.Address(, , , True)
       End If
    Me.Show vbModeless
 End Sub
 Private Sub spn_fl_list_set_SpinDown()

    Dim wk As Variant
    With lst_fl_list
       If .ListCount > 0 And .ListIndex + 1 < .ListCount Then
          wk = .List(.ListIndex)
          .RemoveItem .ListIndex
          .AddItem wk, .ListIndex + 1
          .ListIndex = .ListIndex + 1
          End If
       End With
 End Sub
 Private Sub spn_fl_list_set_SpinUp()

    Dim wk As Variant
    With lst_fl_list
       If .ListCount > 0 And .ListIndex > 0 Then
          wk = .List(.ListIndex)
          .AddItem wk, .ListIndex - 1
          .ListIndex = .ListIndex - 2
          .RemoveItem .ListIndex + 2
          End If
       End With
 End Sub
 Private Sub UserForm_Initialize()

    With Me
       .Width = 360
       .Height = 400
       Set btn_fl_select = .Controls.Add("Forms.CommandButton.1", , True)
       With btn_fl_select
          .Caption = "ファイル選択"
          .Left = 30
          .Top = 12
          .Width = 72
          .Height = 24
          End With
       Set lst_fl_list = .Controls.Add("Forms.LIstBox.1", , True)
       With lst_fl_list
          .Left = 30
          .Top = 48
          .Width = 264
          .Height = 252
          End With
       Set spn_fl_list_set = .Controls.Add("Forms.SpinButton.1", , True)
       With spn_fl_list_set
          .Left = 294
          .Top = 48
          .Width = 18
          .Height = 252
          .ControlTipText = "選択ファイルを上下に移動"
          End With
       Set btn_rg_select = .Controls.Add("Forms.CommandButton.1", , True)
       With btn_rg_select
          .Caption = "画像貼付セル範囲選択"
          .Left = 30
          .Top = 312
          .Width = 114
          .Height = 24
          End With
       Set btn_paste_exec = .Controls.Add("Forms.CommandButton.1", , True)
       With btn_paste_exec
          .Caption = "貼付実行"
          .Left = 144
          .Top = 312
          .Width = 72
          .Height = 24
          End With
       Set lbl_rg_add = .Controls.Add("Forms.Label.1", , True)
       With lbl_rg_add
          .Caption = ""
          .Font.Size = 16
          .Left = 30
          .Top = 342
          .Width = 282
          .Height = 24
          .SpecialEffect = fmSpecialEffectSunken
          .BackColor = &H80000009
          .ForeColor = &H80000006
          End With
       End With
 End Sub
 Private Sub btn_paste_exec_Click()
    Dim pic As Picture
    Dim crng As Range
    Dim rng As Range
    Dim ele As Variant
    Dim flnm As Variant
    Dim g0 As Long, g1 As Long
    Dim ff As Boolean
    g1 = 0
    If lst_fl_list.ListCount > 0 Then
       On Error Resume Next
       Set rng = Application.Range(lbl_rg_add.Caption)
       If Err.Number = 0 Then
          flnm = lst_fl_list.List()
          g0 = 0
          For Each crng In rng
             Err.Clear
             ff = False
             If g0 = 0 Then ff = True
             If chk_rng(crng, ff) = 0 Then
                Set pic = crng.Parent.Pictures.Insert(flnm(LBound(flnm) + g0, 0))
                If Err.Number = 0 Then
                   With crng.MergeArea
                      pic.Left = .Left
                      pic.Top = .Top
                      pic.Width = .Width
                      pic.Height = .Height
                      pic.Placement = xlMoveAndSize
                      .Parent.Hyperlinks.Add _
                          Anchor:=pic.ShapeRange.Item(1), _
                          Address:="", SubAddress:=.Address(, , , True), _
                          ScreenTip:=flnm(LBound(flnm) + g0, 0)
                      g0 = g0 + 1
                      End With
                Else
                   MsgBox Err.Description
                   Exit For
                   End If
                End If
             Next
          End If
       On Error GoTo 0
       End If
 End Sub 
 Function chk_rng(crng As Range, Optional first As Boolean = False) As Long

    Static radd() As Variant
    Static fcnt As Long
    Dim ans As Variant
    If first = True Then
       Erase radd()
       fcnt = 0
       End If
    If fcnt = 0 Then
       ans = CVErr(1004)
    Else
       ans = Application.Match(crng.MergeArea.Address(, , , True), radd(), 0)
       End If
    chk_rng = 1
    If IsError(ans) Then
       ReDim Preserve radd(1 To fcnt + 1)
       radd(fcnt + 1) = crng.MergeArea.Address(, , , True)
       fcnt = fcnt + 1
       chk_rng = 0
       End If
 End Function

標準モジュールには、

 Sub 画像貼付() 
    UserForm1.Show vbModeless
 End Sub

 これだけ・・・。

 画像貼付を実行して試してみて下さい。

 >リストボックス内に表示できないのです。 
 UserForm1のモジュールの　UserForm_Initialize()　でコントロールの作成や位置やサイズの
 設定を行っています。ここのコードを調べて、調節してみてください。
 この仕様でもわずらわしさは残りますが、この程度で妥協してみては？

 ichinose

　いろいろありがとうございました。
　リストボックスのサイズの変更は解決し、
　
　ユーザーフォームを作成し、
　
　教えていただいたコードでできました。

　すごいです!!

　もう一点、お教えいただければと思い、投稿させていただきます。

　画像を貼付する結合セルは７箇所なのですが、セルは固定になることになりました。

　（A22、Y22、A10、D10、C32、K32、Q35）の７箇所です。

　この場合のコードは、どうなりますか？

 >リストボックスのサイズの変更は解決し、
 でしたら、その変更箇所を提示してください。

 >画像を貼付する結合セルは７箇所なのですが、セルは固定になることになりました。

 私が提示したコードは、貼り付けセル範囲は、自由に選択できるようになっていますよね？

 これをどのような仕様にすればよいと思いますか？

 ichinose

コメント返信：

[ 一覧(最新更新順) ]

[[20100617110410]] 『画像の貼付』（どびー） ページの最後に飛ぶ

[[20100617110410]]　『画像の貼付』（どびー）　ページの最後に飛ぶ