[[20080215151052]]　『挿入した画像ファイル名の表示』（みぃ）　ページの最後に飛ぶ

『挿入した画像ファイル名の表示』（みぃ）

 現在､複数の画像ファイルを一括で挿入するというソフトを
 運良く見つけ、ダウンロードすることができました｡
 しかし､貼り付けたい画像がすべて似ているため､
 貼り付けたファイル名を画像の下､
 もしくは画像の上にポインタをおいた時､コメントのように
 ファイル名が表示されないものかと､頭をひねっております｡

 ダウンロードしたソフトは､こちらでいただいたものです｡
　http://www.katch.ne.jp/~kiyopon/soft/fukuzu.htm

 これに何かを足せば､
 例えば､ウィンドウをもひとつ出して､｢ファイル名を表示させる｣とか･･･｡

 こちらでいろいろ勉強しているのですが､
 どこへ何を入れていいのやら､マクロがまったく解らないため混乱しています｡

 どうぞよろしくお願いいたします｡

リンクのアドインのコードは見ていませんが、
仕様の概要はわかりました。

こんな仕様にしました。

以下に示すコード画像配置を実行すると、

・ファイル選択ダイアログが表示されますから、

そこで貼り付けたい画像ファイルを選択してください。複数選択も可能です。

・セル範囲選択の画面が表示されますから、
　選択したファイル数と等しくなるようにセル範囲を選択してください。
　尚、結合セルは想定していません。

・選択したセルの大きさに画像を貼り付けます。

・選択したセルには、その画像のファイル名が設定されます。

・それぞれの画像をクリックすると　そのファイル名が表示されます。

標準モジュールに

'==============================================================================

Option Explicit

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
    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
             Set pic = crng.Parent.Pictures.Insert(flnm(LBound(flnm) + g0))
             If Err.Number = 0 Then
                With crng
                   pic.Left = .Left
                   pic.Top = .Top
                   pic.Width = .Width
                   pic.Height = .Height
                   pic.Placement = xlMoveAndSize
                   pic.ShapeRange.Item(1).OnAction = _
                         ThisWorkbook.Name & "!disp_name"
                   .ShrinkToFit = True
                   .Value = flnm(LBound(flnm) + g0)
                   g0 = g0 + 1
                   End With
             Else
                MsgBox Err.Description
                Exit For
                End If

             Next
          End If
       On Error GoTo 0
       End If
End Sub

'====================================================================================

Sub disp_name()

    Dim shp As Shape
    If TypeName(Application.Caller) = "String" Then
       Set shp = ActiveSheet.Shapes(Application.Caller)
       MsgBox shp.TopLeftCell.Value
       End If
End Sub

ＨＮ忘れました。

ichinose@今日は、血圧が高そう

 ichinose 様

 こんなへんてこな問いにありがとうございました｡
 御礼が遅くなってしまって申し訳ございません｡

 入れてみたコードを使わず､教えていただいた上のコードを
 標準モジュールで新たに作成し､実行したところ､
 うまく貼り付けができました｡

 しかし､言葉が足りなくて申し訳ないのですが､
 大きな画像を圧縮して､結合したセルに貼り付けたいのです｡

 正確には 約20㎝×約27㎝の画像ファイルを
 12行×4列に結合したセルに貼り付けます｡

 入れてみたコードを参照しながら､
 教えていただいたコードをアレンジしてもう少々試してみます｡

 もしお手間でなかったら､またお知恵をお借りしたく存じます｡
 よろしくお願いいたします｡

ちょっと仕様を変更しました。

別のサイトの質問スレッドが参考になりました。

前回と違い、画像をクリックではなく、画像上にマウスをあてた時にそのファイル名を

表示する仕様にしました。

結合セルにも対応しています。

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
                      .Parent.Hyperlinks.Add _
                          Anchor:=pic.ShapeRange.Item(1), _
                          Address:="", SubAddress:=.Address(, , , True), _
                          ScreenTip:=flnm(LBound(flnm) + g0)
                      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

ichinose様っ！でいいんですよね｡

 ありがとうございますぅ(涙)｡
 実は昨日､一日中どうやったら･･･と悩みまくっていたのですが､
 まったく解決に至らず､一晩持ち越ししてました｡

 なのに･･･｡

 やってみました｡
 そうっ､こういうのが･･･｡

 えっと､画像が選んだ順とは関係なく並んでいます(涙)｡
 この場合､入力規則のようなものが必要になりますか？

ＨＮ、忘れました。ichinoseです。

＊＊＊　画像が選んだ順とは関係なく並んでいます(涙)｡

そこまでやると本格的にＶＢＡすることになってしまいますねえ！！

ユーザーフォームを使います。

ユーザーフォーム（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 f_list As Variant
    f_list = Application.GetOpenFilename(, , "Select picture files", , True)
    lst_fl_list.Clear
    If TypeName(f_list) <> "Boolean" Then
       With lst_fl_list
          .List = f_list
          .ListIndex = 0
          End With
       End If
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

これだけ・・・。

画像貼付を実行して試してみて下さい。
Excel2002で試した限りでは　正常に作動しています。

 ichinose様

 なんでこんなことできるんですか･･･｡
 ありがとうございますっ！
 早速わたしも動作テストをしてみたところ
 できましたよぅ(涙)｡

 すんごい助かりました｡
 ところがまだまだ
 「こうしてこうしてこういうのが～」という声が聞こえてきます｡
 もっと自分でも勉強してみるつもりです｡
 また､解らない点がありましたら
 ご教授いただきたく存じます｡
　
 遅い時間までいろいろと考えてくださって
 ほんとにどうもありがとうございました｡

コメント返信：

[ 一覧(最新更新順) ]

[[20080215151052]] 『挿入した画像ファイル名の表示』（みぃ） ページの最後に飛ぶ

[[20080215151052]]　『挿入した画像ファイル名の表示』（みぃ）　ページの最後に飛ぶ