VBでのListViewを仮想モードでサムネイル画像作成

Imports System.Threading

Public Class Form1

  Const thumbnailwidth As Integer = 50
  Const thumbnailheight As Integer = 40

  Private listitem As New List(Of ListViewItem)
  Private thumbnailCache As New Dictionary(Of String, Image)
  Private listlock As New Object
  Private cts As CancellationTokenSource
  Private cachetask As Task

  Private Sub Form1_Load(sender As Object, e As EventArgs) Handles MyBase.Load
    Dim imagelist1 As New ImageList
    imagelist1.ImageSize = New Size(thumbnailwidth, thumbnailheight)
    ListView1.LargeImageList = imagelist1
    ListView1.OwnerDraw = True
  End Sub


  Private Sub Button1_Click(sender As Object, e As EventArgs) Handles Button1.Click
    Dim imageDir As String = "C:\Users\user\Pictures" ' 画像ディレクトリ
    Dim jpgFiles As IEnumerable = System.IO.Directory.EnumerateFiles(imageDir, "*.jpg", IO.SearchOption.AllDirectories)

    'サムネイルキャッシュ作成中であればキャンセル
    If cachetask?.Status = TaskStatus.Running Then
      cts.Cancel()
      cachetask.Wait()
    End If

    listitem.Clear()
    thumbnailCache.Clear()

    For Each file As String In jpgFiles
      Dim item = New ListViewItem(file)
      listitem.Add(item)
    Next
    ListView1.VirtualMode = True
    ListView1.VirtualListSize = listitem.Count

    'キャッシュ作成開始
    CreateCache()
  End Sub

  Private Sub ListView1_RetrieveVirtualItem(sender As Object, e As RetrieveVirtualItemEventArgs) Handles ListView1.RetrieveVirtualItem
    If e.Item Is Nothing Then e.Item = listitem(e.ItemIndex)
  End Sub


  Function createThumbnail(filename As String) As Image
    Dim canvas As New Bitmap(thumbnailwidth, thumbnailheight)

    Using original = Bitmap.FromFile(filename)

      Using g As Graphics = Graphics.FromImage(canvas)
        Using WhiteBrush = New SolidBrush(Color.White)
          g.FillRectangle(WhiteBrush, 0, 0, thumbnailwidth, thumbnailheight)
        End Using

        Dim fw As Double = CDbl(thumbnailwidth) / CDbl(original.Width)
        Dim fh As Double = CDbl(thumbnailheight) / CDbl(original.Height)
        Dim scale As Double = Math.Min(fw, fh)

        Dim w2 As Integer = CInt(original.Width * scale)
        Dim h2 As Integer = CInt(original.Height * scale)

        g.DrawImage(original, (thumbnailwidth - w2) \ 2, (thumbnailheight - h2) \ 2, w2, h2)
      End Using
    End Using

    Return canvas
  End Function


  Private Sub CreateCache()
    cts = New CancellationTokenSource
    cachetask = Task.Factory.StartNew(Sub()
                                        Try

                                          For Each item In listitem
                                            If thumbnailCache.ContainsKey(item.Text) = False Then
                                              Dim thumbnail As Image = createThumbnail(item.Text)
                                              SyncLock listlock
                                                If thumbnailCache.ContainsKey(item.Text) = False Then
                                                  thumbnailCache.Add(item.Text, thumbnail)
                                                End If
                                              End SyncLock
                                              Threading.Thread.Sleep(0)
                                              cts.Token.ThrowIfCancellationRequested()
                                            End If
                                          Next

                                        Catch ex As OperationCanceledException
                                          Console.WriteLine("キャッシュ作成キャンセル")
                                        End Try

                                      End Sub, cts.Token)

  End Sub

  Private Sub ListView1_DrawItem(sender As Object, e As DrawListViewItemEventArgs) Handles ListView1.DrawItem
    Dim filiename As String = e.Item.Text
    Dim thumbnail As Image

    'サムネイルキャッシュに含まれている場合はキャッシュを
    'そうでない場合はサムネイルを作成、キャッシュに追加したのち描画する
    If thumbnailCache.ContainsKey(filiename) Then
      thumbnail = thumbnailCache(filiename)
    Else
      thumbnail = createThumbnail(filiename)
      SyncLock listlock
        If thumbnailCache.ContainsKey(filiename) = False Then
          thumbnailCache.Add(filiename, thumbnail)
        End If
      End SyncLock
    End If

    'アイテムの描画
    Dim imagerect As New Rectangle(New Point(e.Bounds.X + ((e.Bounds.Width - thumbnail.Width) / 2), e.Bounds.Y), New Size(thumbnail.Width, thumbnail.Height))

    e.DrawDefault = False
    e.DrawBackground()
    e.Graphics.DrawImage(thumbnail, imagerect)

    Dim stringFormat = New StringFormat()
    stringFormat.Alignment = StringAlignment.Center
    stringFormat.LineAlignment = StringAlignment.Center
    e.Graphics.DrawString(e.Item.Text, ListView1.Font, Brushes.Black, New RectangleF(e.Bounds.X, e.Bounds.Y + imagerect.Height + 5, e.Bounds.Width, e.Bounds.Height - imagerect.Height - 5), stringFormat)

    e.DrawFocusRectangle()
  End Sub

End Class