フォームに画像を表示する

フォームに画像を表示する

ユーザーフォームに画像を表示します。

画面イメージ

DFD図

ソースコード

' モジュールレベル変数
Dim imgPaths() As String  ' 画像パスの配列
Dim currentIndex As Long  ' 現在表示中のインデックス

' ==== 前の画像ボタン ====
Private Sub CommandButton2_Click()
    If currentIndex > 1 Then
        currentIndex = currentIndex - 1
        ShowImage currentIndex
    Else
        MsgBox "最初の画像です", vbInformation
    End If
End Sub

' ==== 次の画像ボタン ====
Private Sub CommandButton3_Click()
    If currentIndex < UBound(imgPaths) Then
        currentIndex = currentIndex + 1
        ShowImage currentIndex
    Else
        MsgBox "最後の画像です", vbInformation
    End If
End Sub

Private Sub CommandButton4_Click()
Call loadSHeet
End Sub

Private Sub Image1_BeforeDragOver(ByVal Cancel As MSForms.ReturnBoolean, ByVal Data As MSForms.DataObject, ByVal X As Single, ByVal Y As Single, ByVal DragState As MSForms.fmDragState, ByVal Effect As MSForms.ReturnEffect, ByVal Shift As Integer)

End Sub

Private Sub UserForm_Initialize()
Call loadSHeet
End Sub

' ==== 画像表示処理 ====
Private Sub ShowImage(index As Long)
    Dim path As String
    path = imgPaths(index)

    If Dir(path) = "" Then
        MsgBox "画像ファイルが存在しません：" & vbCrLf & path, vbExclamation
        Exit Sub
    End If
    
    With Image1
        .Picture = LoadPicture(path)
        .PictureSizeMode = fmPictureSizeModeZoom
    End With
End Sub

Private Sub CommandButton1_Click()
  Call loadFilePath
End Sub

Sub loadSHeet()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long

    Set ws = ThisWorkbook.Sheets("imagelist")

    ' 最終行を取得（ヘッダは1行目）
    lastRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row

    If lastRow < 2 Then
        MsgBox "画像が見つかりません", vbExclamation
        Exit Sub
    End If

    ' パスを配列に格納（2行目から）
    ReDim imgPaths(1 To lastRow - 1)
    For i = 2 To lastRow
        imgPaths(i - 1) = ws.Cells(i, 2).Value
    Next i

    currentIndex = 1
    ShowImage currentIndex
End Sub

Sub loadFilePath()
    Dim fDialog As FileDialog
    Dim folderPath As String
    Dim fileName As String
    Dim rowNum As Long
    Dim ws As Worksheet
    Dim fso As Object
    Dim folder As Object
    Dim file As Object

    ' === フォルダ選択ダイアログ ===
    Set fDialog = Application.FileDialog(msoFileDialogFolderPicker)
    
    With fDialog
        .Title = "フォルダを選択してください"
        .AllowMultiSelect = False
        If .Show <> -1 Then
            MsgBox "フォルダが選択されませんでした。", vbExclamation
            Exit Sub
        End If
        folderPath = .SelectedItems(1)
    End With
    
    ' === imagelist シートの取得・初期化 ===
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("imagelist")
    If ws Is Nothing Then
        Set ws = ThisWorkbook.Sheets.Add
        ws.Name = "imagelist"
    End If
    On Error GoTo 0
    
    ws.Cells.ClearContents
    ws.Range("A1").Value = "ファイル名"
    ws.Range("B1").Value = "フルパス"
    
    ' === フォルダ内のファイル取得 ===
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set folder = fso.GetFolder(folderPath)
    
    rowNum = 2
    For Each file In folder.Files
        ws.Cells(rowNum, 1).Value = file.Name
        ws.Cells(rowNum, 2).Value = file.path
        rowNum = rowNum + 1
    Next file

    MsgBox "フルパス一覧の出力が完了しました！", vbInformation

End Sub