C# と VB.NET の質問掲示板

'　　　　　　　　　　　　　　　　　（続き）
'　　　　　　　　　　　　　　　（コードの始まり）　　　　１／４

Imports System.Collections
Imports System.ComponentModel
Imports System.Data
Imports System.IO
Imports System.Runtime.InteropServices

'エントリポイント
Public Class Program
    Public Shared Sub Main()
        Application.EnableVisualStyles()
        Dim frm As New Launcher(Of SnakeExplorer)
        ' マイドキュメントの中身を表示
        Dim path As String = Environment.GetFolderPath(Environment.SpecialFolder.Personal)
        frm.SetStartupInformation(path)
        Application.Run(frm)
    End Sub
End Class


'（丸ごと再利用可能）汎用ランチャー
Public Class Launcher(Of T As {New, ContentSnakeBase})
    Inherits System.Windows.Forms.Form

    Dim WithEvents BtnRun As New Button
    Dim WithEvents frm As T
    Dim isTracking As Boolean = False
    Dim offset As New Point(0, 0)

    Public Sub New()
        Me.ClientSize = New Size(100, 50)
        Me.FormBorderStyle = Windows.Forms.FormBorderStyle.Fixed3D
        Me.MinimizeBox = False
        Me.MaximizeBox = False
        Me.Text = "ランチャー"
        BtnRun.Text = "Start"
        BtnRun.Dock = DockStyle.Fill
        Me.Controls.Add(BtnRun)
    End Sub

    Private m_startinfo As New Object
    Public Sub SetStartupInformation(ByVal info As Object)
        Me.m_startinfo = info
    End Sub

    Private Sub BtnRun_Click(ByVal sender As Object, ByVal e As System.EventArgs) Handles BtnRun.Click
        If isTracking = False Then
            isTracking = True

            frm = New T
            ' ↓Lancher移動時にSnakeもついてくるようにするために必要な情報
            offset = New Point(frm.Left - Me.Left, frm.Top - Me.Top)
            ' StartupInformation（この例ではマイドキュメントのパス）を渡す
            frm.StartupInformation = Me.m_startinfo
            ' 最初のContentをLauncherの真下に表示
            frm.FirstContentScreenPosition = New Point(Me.Left, Me.Top + Me.Height)
            ' 輪郭線を描画
            frm.ShowContentsBorderLine = True
            frm.ContentsBorderLineColor = Color.BurlyWood
            frm.ContentsBorderLineWidth = 5
            ' ↓Trueにすると、指定時間間隔毎にカーソルの方向へSnakeが延伸
            ' ↓Trueのほうが操作性がまだまし
            frm.AutoSnake = True
            frm.AutoSnakeInterval = 200 '←単位はミリ秒
            ' ↓マウスを逆方向に動かした場合に、Snakeを短縮させるなら、True
            ' ↓（※AutoSnake=Trueの場合は、CanAutoShrink=Falseにしたほうが良いです）
            ' ↓SnakeExplorerでは、Trueにするとファイル、フォルダが正しく表示されない場合がある。
            ' ↓（赤いフォルダを超えてSnakeを短縮させた場合）
            frm.CanAutoShrink = False

            frm.Show()
            Cursor.Position = New Point(Me.Left + 30, Me.Top + Me.Height + 30)
        Else
            'Snake表示中に再度ボタンを押すと、Snakeを閉じる
            If frm IsNot Nothing Then frm.Close()
        End If
    End Sub

    Private Sub frm_FormClosed(ByVal sender As Object, _
        ByVal e As System.Windows.Forms.FormClosedEventArgs) Handles frm.FormClosed
        isTracking = False
    End Sub

    Private Sub Me_LocationChanged(ByVal sender As Object, _
        ByVal e As System.EventArgs) Handles Me.LocationChanged
        If isTracking = False Then Return
        frm.Location = New Point(Me.Location.X + offset.X, Me.Location.Y + offset.Y)
    End Sub
End Class


'（丸ごと再利用可能）ファイル／フォルダのアイコン画像取得用のクラス
Public Class Shell32
    Public Const SHGFI_ICON As UInt32 = &H100
    Public Const SHGFI_LARGEICON As UInt32 = &H0
    Public Const SHGFI_SMALLICON As UInt32 = &H1

    Public Structure SHFILEINFO
        Public hIcon As IntPtr
        Public iIcon As Integer
        Public dwAttributes As UInt32
        <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=260)> _
        Public szDisplayName As String
        <MarshalAs(UnmanagedType.ByValTStr, SizeConst:=80)> _
        Public szTypeName As String
    End Structure

    <DllImport("shell32.dll")> _
    Public Shared Function SHGetFileInfo(ByVal pszPath As String, ByVal dwFileAttributes As UInt32, _
        ByRef psfi As SHFILEINFO, _
        ByVal cbFileInfo As UInt32, _
        ByVal uFlags As UInt32) As IntPtr
    End Function

    ''' <summary>
    ''' 32 x 32サイズのアイコンを取得
    ''' </summary>
    ''' <param name="fileordirectoryname">ファイル名、ディレクトリ名</param>
    Public Shared Function Get32x32Icon(ByVal fileordirectoryname As String) As Icon
        Dim shfi As New SHFILEINFO
        Dim hImageLarge As IntPtr
        hImageLarge = Shell32.SHGetFileInfo(fileordirectoryname, 0, shfi, _
            Convert.ToUInt32(Marshal.SizeOf(shfi)), Shell32.SHGFI_ICON Or Shell32.SHGFI_LARGEICON)
        Dim ic As Icon = Icon.FromHandle(shfi.hIcon)
        Return ic
    End Function

    ''' <summary>
    ''' 16 x 16サイズのアイコンを取得
    ''' </summary>
    ''' <param name="fileordirectoryname">ファイル名、ディレクトリ名</param>
    Public Shared Function Get16x16Icon(ByVal fileordirectoryname As String) As Icon
        Dim shfi As New SHFILEINFO
        Dim hImageSmall As IntPtr
        hImageSmall = Shell32.SHGetFileInfo(fileordirectoryname, 0, shfi, _
            Convert.ToUInt32(Marshal.SizeOf(shfi)), Shell32.SHGFI_ICON Or Shell32.SHGFI_SMALLICON)
        Dim ic As Icon = Icon.FromHandle(shfi.hIcon)
        Return ic
    End Function
End Class

'　　　　　　　　　　　　　　　　　（続く）　　　　１／４

'　　　　　　　　　　　　　　　　　（続き）　　　　２／４

'派生クラスの一例（Explorer関連の処理を記述）
Public Class SnakeExplorer
    Inherits ContentSnakeBase

    Private fileNumber As Integer = 0
    Private FileList As List(Of FileSystemInfo)
    Private directoryDepth As Integer = 0

    Private Sub initializeFileList(ByVal path As String)
        If FileList Is Nothing Then
            FileList = New List(Of FileSystemInfo)
        Else
            FileList.Clear()
        End If
        Dim ssd() As String = Directory.GetDirectories(path)
        Dim ssf() As String = Directory.GetFiles(path)
        For Each ss As String In ssd
            FileList.Add(New DirectoryInfo(ss))
        Next
        For Each ss As String In ssf
            FileList.Add(New FileInfo(ss))
        Next
        fileNumber = 0
    End Sub

    Protected Overrides Function OnCreateNewContent(ByVal cx As Integer, ByVal cy As Integer, _
        ByVal dr As Direction) As System.Windows.Forms.Control
        'cx、cyはContent（ここではControlと同義）を格子に見立てたときの座標です。
        'フォーム起動時に最初に表示されるContentの(cx,cy)は(100,100)、
        'その右隣のContentは(101,100)、下隣のContentは(100,101)です。
        'ここで(100,100)の「100」は、基本クラスのInitialCX、InitialCYで定義されています。
        '
        'drは、Contentの展開方向です（例えば、下に展開した場合はDirection.Down）
        '
        'Contentを表示する場合は、Controlインスタンスを返します。
        'Contentを作成しない場合はNothingを返してください。
        '各Contentのサイズが同一でない場合も多分動作しますが、画面表示が変になる場合があります。
        '（例えば、Contentが重なって表示される、Formの端でContentの一部が描画されない等）
        '
        If Me.FileList Is Nothing Then
            ' ↓StartupInformationがNothingになることはない
            Dim path As String = Me.StartupInformation.ToString
            If Directory.Exists(path) = False Then
                Throw New DirectoryNotFoundException("ディレクトリ " + path + " が見つかりません。")
            End If
            initializeFileList(path)
        End If
        If FileList.Count < fileNumber + 1 Then
            '表示するファイルがない
            Return Nothing
        End If
        Dim ofe As New OneFileExplorer(FileList.Item(fileNumber), directoryDepth)
        fileNumber += 1
        AddHandler ofe.DoubleClick, AddressOf Me.OneFileExplorer_DoubleClick
        Return ofe
    End Function

    Protected Overrides Sub OnClosingContent(ByVal cw As ContentWrapper)
        'Content消去前にイベントハンドラを削除
        Dim ofe As OneFileExplorer = DirectCast(cw.Content, OneFileExplorer)
        RemoveHandler ofe.DoubleClick, AddressOf Me.OneFileExplorer_DoubleClick
        If fileNumber >= 1 Then fileNumber -= 1
    End Sub

    Protected Overrides Sub OnHotContentChanging(ByVal cw As ContentSnakeBase.ContentWrapper)
        '今までHotContentだったContentの背景色を元に戻す
        Dim ofe As OneFileExplorer = DirectCast(cw.Content, OneFileExplorer)
        If ofe.BackColor = ofe.colorHot Then
            ofe.BackColor = ofe.colorDefault
        End If
    End Sub

    Protected Overrides Sub OnHotContentChanged(ByVal cw As ContentSnakeBase.ContentWrapper)
        'HotContentの背景色を変更
        Dim ofe As OneFileExplorer = DirectCast(cw.Content, OneFileExplorer)
        If ofe.BackColor = ofe.colorDefault Then
            ofe.BackColor = ofe.colorHot
        End If
    End Sub

    Protected Overrides Sub OnPaintContent(ByVal cw As ContentSnakeBase.ContentWrapper, _
        ByVal e As System.Windows.Forms.PaintEventArgs)
        '
        '引数cwには、Contentの連接方向や座標データが格納されているので、
        'これらの情報を用いて描画したい場合にはここに処理を書いてください。
        '
    End Sub

    Private Sub OneFileExplorer_DoubleClick(ByVal sender As Object, ByVal e As System.EventArgs)
        Dim mc As OneFileExplorer = DirectCast(sender, OneFileExplorer)
        Dim ty As Type = mc.FSI.GetType
        Dim ss As String = mc.FSI.FullName
        If ty Is GetType(DirectoryInfo) Then
            'フォルダをダブルクリック
            Me.TruncateSnake(mc)
            mc.BackColor = mc.colorDirectory
            initializeFileList(ss)
            Me.directoryDepth = mc.directoryDepth + 1
        ElseIf ty Is GetType(FileInfo) Then
            'ファイルをダブルクリック
            Process.Start(ss)
            Me.Close()
        End If
    End Sub

    '「Snakeのパーツ」を定義したクラス
    Private Class OneFileExplorer
        Inherits System.Windows.Forms.Control

        '↓ディレクトリ階層の深さに応じてBackColorが変化します。
        Private Allcolor() As Color = {Color.Azure, Color.AntiqueWhite, Color.LemonChiffon, Color.Wheat}
        '↓環境に応じて適宜変更してください。Controlのサイズはこれに連動して決定されます。
        Private IconSize As New Size(40, 40)

        Public colorDefault As Color = Color.White
        Public colorDirectory As Color = Color.LightSalmon
        Public colorHot As Color = Color.Aqua
        Public ReadOnly FSI As FileSystemInfo
        Public ReadOnly IconImage As Icon
        Public directoryDepth As Integer = 0
        Private m_iconRectangle As Rectangle
        Private m_textRectangle As Rectangle
        Private m_strFormat As New StringFormat

        Public Sub New(ByVal fsi As FileSystemInfo, ByVal directorydepth As Integer)
            Me.FSI = fsi
            Me.directoryDepth = directorydepth
            Dim i As Integer = directorydepth Mod Allcolor.Length
            Me.colorDefault = Allcolor(i)
            Me.BackColor = Me.colorDefault
            Me.IconImage = Shell32.Get32x32Icon(fsi.FullName)
            Dim sz As Size = Me.IconSize
            Me.Size = New Size(CInt(sz.Width * 2), CInt(sz.Height * 2.3))
            m_iconRectangle = New Rectangle(CInt(sz.Width * 0.5), CInt(sz.Height * 0.25), _
                sz.Width, sz.Height)
            m_textRectangle = New Rectangle(CInt(sz.Width * 0.1), CInt(sz.Height * 1.25) + 3, _
                CInt(sz.Width * 1.8), 40)
            m_strFormat.Alignment = StringAlignment.Center
        End Sub

        Protected Overrides Sub OnPaint(ByVal e As System.Windows.Forms.PaintEventArgs)
            'アイコンとファイル名を直接描画
            e.Graphics.DrawIcon(Me.IconImage, m_iconRectangle)
            e.Graphics.DrawString(Me.FSI.Name, SystemFonts.MessageBoxFont, Brushes.Black, _
                m_textRectangle, m_strFormat)
            MyBase.OnPaint(e)
        End Sub
    End Class

End Class

'　　　　　　　　　　　　　　　　　（続く）　　　　２／４