【VBA】画像ファイルのサムネイルとハイパーリンクを設定

0

    <機能>

    (1)ファイルピッカーで画像ファイルを選択します

    (2)シートに画像ファイルのハイパーリンクを設定します

    (3)シートの画像ファイルのサムネイルを設定します

     

    <実行イメージ>

    画像リスト実行イメージ,Hyperlinks,Pictures,ハイパーリンク,VBA,

    サムネイルクリック,Hyperlinks,Pictures,ハイパーリンク,VBA,

     

    <動作検証>

    Microsoft Office 365 バージョン1905(11629.20214)

     

    <使い方>

    適当なところにソースを貼り付けてください

    画像をシートに並べて表示する() を実行します

     

     

    '/********************************************************
    '/* 画像をシートに並べてハイパーリンクを設定する
    '/* 1.画像ファイル(.jpg)を選択する(複数選択可)
    '/* 2.画像ファイルのサムネイルをシートに並べる
    '/* 3.画像ファイルへのハイパーリンクをシートに設定する
    '/********************************************************

    Public Sub 画像をシートに並べて表示する()
        On Error GoTo ErrorOccurred

        Dim gazoFiles() As String
        Dim iret As Integer, i As Integer
        Dim stcol As Integer, strow As Integer
        Dim filename As String

        '//ファイル選択ダイアログで画像ファイルを選択する
        With Application.FileDialog(msoFileDialogFilePicker)
            '選択可能ファイル(.jpg)設定
            .Filters.Add "画像ファイル(Jpeg)", "*.jpg"
            '複数ファイル選択可能
            .AllowMultiSelect = True

            'ファイルピッカー表示
            If .Show = False Then
                Exit Sub
            Else
                'SelectedItemsはインデックス1から開始するのでFor文で実装する際は注意
                i = 0
                For Each tmpstr In .SelectedItems
                    ReDim Preserve gazoFiles(i)
                    gazoFiles(i) = tmpstr
                    i = i + 1
                Next
            End If
        End With

        '//シートを初期化していいか確認メッセージを表示する
        iret = MsgBox(ActiveSheet.Name & " : シートを初期化してもよろしいですか?", _
            vbYesNo + vbQuestion, "画像をシートに並べて表示する")
        If iret = vbNo Then Exit Sub

        '//シートを初期化する
        シートクリア ActiveSheet.Name

        '//画像のサムネイルとハイパーリンクを設定
        i = 1
        stcol = 2
        strow = 2
        For Each tmpstr In gazoFiles
            'ハイパーリンクを設定
            '詳細はOfficeデベロッパーセンター参照
            filename = Mid(tmpstr, InStrRev(tmpstr, "¥") + 1)
            Range(Cells(strow, stcol), Cells(strow, stcol)).Select
            ActiveSheet.Hyperlinks.Add _
                    Anchor:=ActiveSheet.Range(Cells(strow, stcol), Cells(strow, stcol)), _
                    Address:=tmpstr, _
                    ScreenTip:=tmpstr, _
                    TextToDisplay:=filename

            'サムネイル画像を設定
            Range(Cells(strow + 1, stcol), Cells(strow + 1, stcol)).Select
            ActiveSheet.Pictures.Insert(tmpstr).Select
            Selection.ShapeRange.Height = 150

            '次の開始位置を算出(横方向は最大4画像とする)
            If (i Mod 4) = 0 Then
                stcol = 2
                strow = strow + 12
            Else
                stcol = stcol + 13
            End If
            '次の画像はi番目
            i = i + 1
        Next

        Range("A1").Select
        Exit Sub

    ErrorOccurred:
        MsgBox "何かエラーが発生しました", vbCritical
    End Sub

     

    '/********************************************************
    '/ シートをクリアする
    '/ stname:クリア対象シート名
    '/********************************************************

    Private Sub シートクリア(ByVal stname As String)
        Dim sp As Variant

        '//シート選択
        ThisWorkbook.Sheets(stname).Activate
        '//セルを初期化する
        Cells.Select
        Selection.UnMerge
        Selection.Clear
        Selection.ColumnWidth = 3
        Selection.RowHeight = 17
        Selection.Font.Name = "Meiryo UI"
        Selection.Font.Size = 12
        Selection.Borders.LineStyle = False
        '//中央揃えを設定
        Selection.HorizontalAlignment = xlLeft
        Selection.VerticalAlignment = xlCenter
        '//セルの折り返しを解除
        Selection.WrapText = False

        '//オートシェイプを削除する
        For Each sp In ActiveSheet.Shapes
            sp.Delete
        Next

        ActiveWindow.Zoom = 80
        Range("A1").Select
    End Sub
     

    よろしければポチッと押してください


    プログラマー ブログランキングへ

     



    selected entries

    categories

    calendar

    S M T W T F S
      12345
    6789101112
    13141516171819
    20212223242526
    2728293031  
    << October 2019 >>

    profile

    others

    archives