Shapeを使って画像管理−UserPictureメソッド
エクセルではさまざまな方法で画像をワークシート、コントロール、その他
に読み込むことが出来ます。

ここではOnActionプロパティーにマクロを登録できる、テキストを追加できる、
という点からShapeを使って画像管理をする方法を考えます。

以下のサンプルでは、ワークシートにサムネイル状にShapeを配置し、FileSearch
オブジェクトを使用して検索したビットマップファイルをUserPictureメソッドを
用いて読み込みます。また、Shapeのクリックにより該当ファイルをユーザフォーム
のImageコントロールに読み込みます。

(前提)ワークシート:1、ユーザフォーム:1(Imageコントロール貼り付け)

Sub Thumnails()

    ActiveSheet.DrawingObjects.Delete'シート上のShapeをすべて削除
    Application.Cursor = xlWait
    Application.ScreenUpdating = False

    Dim TargetPath As String
    Dim Cnt As Integer
    Dim i As Integer, R As Integer, C As Integer
    Dim L As Double, T As Double, W As Double, H As Double
    Dim Sh As Shape

    'セル幅、高さ等の設定
    ActiveSheet.Rows.RowHeight = 5
    ActiveSheet.Columns.ColumnWidth = 2
    For Cnt = 2 To 20 Step 2
    ActiveSheet.Rows(Cnt).RowHeight = 60
    ActiveSheet.Columns(Cnt).ColumnWidth = 15
    Next Cnt

    TargetPath = Environ("windir")

    '”Windows”フォルダ内のBmpファイルを検索します
    With Application.FileSearch
        .NewSearch
        .Filename = "*.bmp"
        .FileType = msoFileTypeAllFiles
        .LookIn = TargetPath
        .SearchSubFolders = False
        .Execute

    R = 2: C = 2 'Shape配置開始セル指定

    For i = 1 To .FoundFiles.Count

        If R > 10 Then R = 2: C = C + 2 
        '1行に5個のShape、1列あけて次の列へ

        With ActiveSheet.Cells(R, C)
            L = .Left: T = .Top: W = .Width: H = .Height
            'Shapeの位置決め
        End With
        Set Sh = ActiveSheet.Shapes.AddShape _
                              (msoShapeRectangle, L, T, W, H)
        Sh.Fill.UserPicture picturefile:=.FoundFiles(i)
        'Pictureの指定
        Sh.TextFrame.Characters.Text = Mid(.FoundFiles(i), _
                    InStr(Len(TargetPath), .FoundFiles(i), "\") + 1)
        'ファイル名を表示
        Sh.TextFrame.Characters.Font.Color = vbWhite '文字色設定
        Sh.TextFrame.Characters.Font.Bold = True '太字
        Sh.TextFrame.VerticalAlignment = xlVAlignBottom '垂直方向の位置
        Sh.TextFrame.HorizontalAlignment = xlHAlignRight '水平方向の位置
        Sh.OnAction = "DisplayPicture" 'マクロの登録
        R = R + 2 '行カウンタ

    Next i

    End With

    Application.ScreenUpdating = True
    Application.Cursor = xlDefault

End Sub

'上記プロシージャの実行でOnActionプロパティーに登録され、
'Shapeのクリックにより呼び出される

Sub DisplayPicture()
'ShapeのTextFrameからファイル名を取得してユーザフォーム上の
'イメージコントロールに読み込む

    UserForm1.Image1.Picture = LoadPicture _
        (Environ("windir") & "\" & _
         ActiveSheet.Shapes(Application.Caller). _
         TextFrame.Characters.Text)
         
    UserForm1.Show

End Sub

※画像を大量にShapeへ読み込んだことによるファイル保存時のサイズ肥大化は
 終了時に以下のような方法でShapeの全削除を行うことで回避できます。

(削除法1)
    ActiveSheet.Shapes.SelectAll
    Selection.Delete
(削除法2)
    ActiveSheet.DrawingObjects.Delete

※上記Thumnailサンプルでは、複数回の実行を前提に、プロシージャの先頭に
削除法2の手法を取り入れてShapeの全削除を行っています。

※上記Thumnailでは、Shapeにファイル名を表示する際、フルパスからのファイ
 ル名取得にMid関数、Instr関数、Len関数を組み合わせていますが、エクセル
 2000の場合にはInstrRev関数やSplit関数があります。これらの詳細について
 はヘルプやテクニック集の他のトピックを参照してください。

Excel97,2000



戻る


Excel Word Access VBA! モーグ