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

<機能>

(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
 

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


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

 



<< | 2/62PAGES | >>

selected entries

categories

calendar

S M T W T F S
1234567
891011121314
15161718192021
22232425262728
2930     
<< September 2019 >>

profile

others

archives