・フォルダ・ファイルの一覧を表示・印刷・保存するプログラムを作成する。

Textプロパティに「&」とアルファベットを入力するとショートカットキーを設定したことになります。

たとえば、ボタンのTextプロパティに「閉じる(&C)」と設定した場合、プログラム実行中に[Alt] + [C]を押すことでこのボタンをクリックすることができます。表示上は「&C」の部分はアンダーバーがついて表示されるので「閉じる(C)」に見えます。

日本語のアプリケーションでは文字列の後ろにかっこつきでショートカットキーを指定するのが普通ですが、ショートカットキーの指定自体はお勧めはしませんがどの位置で行っても構いません。英語のアプリケーションでは「File」や「Tool」のように先頭の文字をショートカットキーにする習慣があります。

    Me.Close()

End Sub

    Dim St As String

    St = Application.ProductName & " " & Application.ProductVersion
    St &= vbNewLine & vbNewLine
    St &= Application.CompanyName

    MsgBox(St, MsgBoxStyle.Information)

End Sub

注意！VB2005とWindows Vistaの組み合わせでは今回はドラッグ＆ドロップできません。

この記事はVB2005+Windows XPの環境で書いたものなのですが、Windows Vistaで同じことをやってもドラッグ＆ドロップが機能しません。VB2008+Windows Vistaならおそらく大丈夫なはずですが未検証です。VB2005のExpress Editionを使用している方は、これを機にVB2008のExpress Editionに乗り換えてみませんか？

    MsgBox(FolderName)

End Sub

'■ShowFileList
''' <summary>ファイル・フォルダの情報の一覧を表示する</summary>
Private Sub ShowFileList()

End Sub

    'ドラッグされている内容がファイルである場合
    If e.Data.GetDataPresent(DataFormats.FileDrop) Then
        'コピーを許可するようにドラッグ元に通知する
        e.Effect = DragDropEffects.Copy
    End If

End Sub

    Dim Name As String

    'ドロップされた内容を取得

    Name = e.Data.GetData(DataFormats.FileDrop)(0)

    If IO.Directory.Exists(Name) Then
        'ドロップされたのがフォルダならばそのまま表示する
        txtFolderName.Text = Name
    Else
        'ドロップされたのがファイルならば親フォルダを表示する
        txtFolderName.Text = IO.Path.GetDirectoryName(Name)
    End If

    '▼フォルダとファイルの一覧を表示
    ReadFileList(txtFolderName.Text)
    ShowFileList()

End Sub

    If FolderBrowserDialog1.ShowDialog = Windows.Forms.DialogResult.OK Then
        txtFolderName.Text = FolderBrowserDialog1.SelectedPath
        'フォルダとファイルの一覧を表示
        ReadFileList(txtFolderName.Text)
        ShowFileList()
    End If

End Sub

    If Asc(e.KeyChar) = Keys.Enter Then
        Me.SelectNextControl(txtFolderName, True, True, True, True)
        e.Handled = True
    End If

End Sub

    If Len(Trim(txtFolderName.Text)) > 0 Then

        '末尾に\を付加
        If Strings.Right(txtFolderName.Text, 1) <> "\" Then
            txtFolderName.Text &= "\"
        End If

        'フォルダとファイルの一覧を表示
        If IO.Directory.Exists(txtFolderName.Text) = True Then

            ReadFileList(txtFolderName.Text)
            ShowFileList()

        Else

            Dim St As String

            lvFiles.Clear()

            '存在しない場合
            St = "存在するフォルダ名を正しく入力してください。" & vbNewLine
            St &= vbNewLine
            St &= "・フォルダをドロップして指定することもできます。" & vbNewLine
            St &= "・右側のボタンをクリックしてフォルダ選択画面を利用することもできます。" & vbNewLine
            MsgBox(St, MsgBoxStyle.Exclamation)

        End If

    Else

        lvFiles.Clear()

    End If

End Sub

    Public Shared IsSize As Boolean                   'サイズを表示するか
    Public Shared IsLastWriteTime As Boolean          '更新日時を表示するか
    Public Shared IsCreationTime As Boolean           '作成日時を表示するか
    Public Shared IsAttributes As Boolean             '属性を表示するか
    Private Const FileName As String = "Settings.txt" '設定ファイル

    '■Read
    ''' <summary>設定ファイルから設定を読み込む</summary>
    Public Shared Sub Read()

        Dim Reader As New IO.StreamReader(Application.StartupPath & "\" & FileName)

        IsSize = CBool(Reader.ReadLine)
        IsLastWriteTime = CBool(Reader.ReadLine)
        IsCreationTime = CBool(Reader.ReadLine)
        IsAttributes = CBool(Reader.ReadLine)

        Reader.Close()

    End Sub

    '■Write
    ''' <summary>設定ファイルに設定を書き込む</summary>
    Public Shared Sub Write()

        Dim Writer As New IO.StreamWriter(Application.StartupPath & "\" & FileName)

        Writer.WriteLine(CStr(IsSize))
        Writer.WriteLine(CStr(IsLastWriteTime))
        Writer.WriteLine(CStr(IsCreationTime))
        Writer.WriteLine(CStr(IsAttributes))

        Writer.Close()

    End Sub

    '■Exists
    ''' <summary>設定ファイルが存在するか確認する</summary>
    ''' <returns>Trueの場合設定ファイルは存在する</returns>
    Public Shared Function Exists() As Boolean

        Return IO.File.Exists(Application.StartupPath & "\" & FileName)

    End Function

    '■SetDefault
    ''' <summary>設定を既定の設定にセットする</summary>
    Public Shared Sub SetDefault()

        IsSize = True
        IsLastWriteTime = True
        IsCreationTime = False
        IsAttributes = True

    End Sub

End Class

    Call ReadSettings()

End Sub

'■[OK]ボタン
Private Sub btnOK_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles btnOK.Click

    Call WriteSettings()
    Settings.Write()

End Sub

'■ReadSettings
''' <summary>現在の設定を画面に表示する</summary>
Private Sub ReadSettings()

    chkSize.Checked = Settings.IsSize
    chkLastWriteTime.Checked = Settings.IsLastWriteTime
    chkCreationTime.Checked = Settings.IsCreationTime
    chkAttributes.Checked = Settings.IsAttributes

End Sub

'■WriteSettings
''' <summary>画面の内容を設定として記録する</summary>
Private Sub WriteSettings()

    Settings.IsSize = chkSize.Checked
    Settings.IsLastWriteTime = chkLastWriteTime.Checked
    Settings.IsCreationTime = chkCreationTime.Checked
    Settings.IsAttributes = chkAttributes.Checked

End Sub

    Dim f As New frmSettings

    If f.ShowDialog() = Windows.Forms.DialogResult.OK Then
        '▼フォルダとファイルの一覧を表示
        ReadFileList(txtFolderName.Text)
        ShowFileList()
    End If

End Sub

上記のコードはVB2005では少しだけ楽に書くことができます。自分でインスタンスを作成しなくてもフォームを呼び出せる機能が追加されているからです。VB2005では次のような記述が可能です。

■リスト１０：VB2005では設定画面の呼び出しをこのように書くこともできる。

    If Settings.Exists Then
        '設定ファイルが存在する場合
        Settings.Read() '設定ファイルを読み込む
    Else
        '設定ファイルが存在しない場合
        Settings.SetDefault() '既定の設定を利用する
    End If

End Sub

'ファイル・フォルダの情報
Private Structure FileProp
    Public Name As String        '名前
    Public Size As Long          'サイズ
    Public LastWriteTime As Date '更新日時
    Public CreationTime As Date  '作成日時
    Public Attributes As String  '属性
    Public IsFolder As Boolean   'フォルダか
End Structure

    Dim ThisFolder As New IO.DirectoryInfo(FolderName)
    Dim oFolder As IO.DirectoryInfo
    Dim oFile As IO.FileInfo
    Dim Prop As FileProp

    FileProps.Clear()

    '▼フォルダの情報を追加

    For Each oFolder In ThisFolder.GetDirectories()
        Prop.Name = oFolder.Name                            '名称
        Prop.Size = 0                                       'サイズ
        Prop.IsFolder = True                                '種類
        Prop.Attributes = GetAttributes(oFolder.Attributes) '属性
        Prop.LastWriteTime = oFolder.LastWriteTime          '更新日
        Prop.CreationTime = oFolder.CreationTime            '作成日
        FileProps.Add(Prop)
    Next

    '▼ファイルの情報を追加

    For Each oFile In ThisFolder.GetFiles()
        Prop.Name = oFile.Name                              '名称
        Prop.Size = oFile.Length                            'サイズ
        Prop.IsFolder = False                               '種類
        Prop.Attributes = GetAttributes(oFile.Attributes)   '属性
        Prop.LastWriteTime = oFile.LastWriteTime            '更新日
        Prop.CreationTime = oFile.CreationTime              '作成日
        FileProps.Add(Prop)
    Next

End Sub

'■GetAttributes
''' <summary>ファイル・フォルダの属性を文字列として返す</summary>
''' <param name="Attributes">属性</param>
''' <returns>属性を表す文字列。各属性はアルファベット１文字で表される。</returns>
''' <remarks>複数の属性を一度に表現可能</remarks>
Private Function GetAttributes(ByVal Attributes As IO.FileAttributes) As String

    Dim strAttributes As String = ""

    '▼隠し属性
    If Attributes And IO.FileAttributes.Hidden Then
        strAttributes &= "H"
    Else
        strAttributes &= " "
    End If

    '▼圧縮属性
    If Attributes And IO.FileAttributes.Compressed Then
        strAttributes &= "C"
    Else
        strAttributes &= " "
    End If

    '▼システム属性
    If Attributes And IO.FileAttributes.System Then
        strAttributes &= "S"
    Else
        strAttributes &= " "
    End If

    '▼読み取り専用属性
    If Attributes And IO.FileAttributes.ReadOnly Then
        strAttributes &= "R"
    End If

    Return strAttributes

End Function

    If Len(Trim(txtFolderName.Text)) > 0 Then

        '末尾に\を付加
        If Strings.Right(txtFolderName.Text, 1) <> "\" Then
            txtFolderName.Text &= "\"
        End If

        'フォルダとファイルの一覧を表示
        If IO.Directory.Exists(txtFolderName.Text) = True Then

            ReadFileList(txtFolderName.Text)
            ShowFileList()

        Else

            Dim St As String

            FileProps.Clear()    '←追加
            lvFiles.Clear()

            '存在しない場合
            St = "存在するフォルダ名を正しく入力してください。" & vbNewLine
            St &= vbNewLine
            St &= "・フォルダをドロップして指定することもできます。" & vbNewLine
            St &= "・右側のボタンをクリックしてフォルダ選択画面を利用することもできます。" & vbNewLine
            MsgBox(St, MsgBoxStyle.Exclamation)

        End If

    Else

        FileProps.Clear()    '←追加
        lvFiles.Clear()

    End If

End Sub

    Dim Prop As FileProp
    Dim ListRow As ListViewItem

    lvFiles.BeginUpdate()
    lvFiles.Clear()

    '▼列の追加

    lvFiles.Columns.Add("名前", 200, HorizontalAlignment.Left)

    If Settings.IsSize Then
        lvFiles.Columns.Add("サイズ", 80, HorizontalAlignment.Right)
    End If

    If Settings.IsLastWriteTime Then
        lvFiles.Columns.Add("更新日時", 120, HorizontalAlignment.Left)
    End If

    If Settings.IsCreationTime Then
        lvFiles.Columns.Add("作成日時", 120, HorizontalAlignment.Left)
    End If

    If Settings.IsAttributes Then
        lvFiles.Columns.Add("属性", 60, HorizontalAlignment.Left)
    End If

    '▼行の追加

    For Each Prop In FileProps

        ListRow = lvFiles.Items.Add(Prop.Name)

        If Prop.IsFolder Then
            ListRow.ImageIndex = 0 'フォルダの場合はアイコンを表示
        End If

        If Settings.IsSize Then
            If Prop.IsFolder Then
                ListRow.SubItems.Add("")
            Else
                ListRow.SubItems.Add(Format(Prop.Size \ 1024, "#,0 KB")) 'サイズ
            End If
        End If

        If Settings.IsLastWriteTime Then
            ListRow.SubItems.Add(Prop.LastWriteTime) '更新日時
        End If

        If Settings.IsCreationTime Then
            ListRow.SubItems.Add(Prop.CreationTime) '更新日時
        End If

        If Settings.IsAttributes Then
            ListRow.SubItems.Add(Prop.Attributes) '属性
        End If

    Next

    lvFiles.EndUpdate()

End Sub

'■[ファイル] - [印刷]メニュー
Private Sub mnuFilePrint_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuFilePrint.Click

    PrintDocument1.Print()

End Sub

'■[ファイル] - [印刷プレビュー]メニュー
Private Sub mnuFilePreview_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles mnuFilePreview.Click

    PrintPreviewDialog1.ShowDialog()

End Sub

'■PrintDocument1_PrintPage
''' <summary>ファイル・フォルダの情報の一覧を印刷(またはプレビュー)する</summary>
''' <remarks>情報はFilePropsコレクションから読み込まれる。
''' FilePropsコレクションに情報をセットするにはReadFileListメソッドを使う。
''' Settingsクラスの設定によって印刷する項目が変る。</remarks>
Private Sub PrintDocument1_PrintPage(ByVal sender As System.Object, ByVal e As System.Drawing.Printing.PrintPageEventArgs) Handles PrintDocument1.PrintPage

    Dim LineTop As Integer         '現在の行の印刷開始縦位置
    Dim LineLeft As Integer        '現在の行の印刷開始横位置(実はどの行でも同じ値)
    Dim LineText As String         '現在の行の印刷内容
    Dim Name As String             '現在の行に印刷すべきファイル・フォルダ名
    Dim NameWidth As Integer = 250 'ファイル・フォルダ名の印刷領域の幅
    Dim LineHeight As Single       '現在の行の高さ
    Dim Prop As FileProp           '現在の行に印刷すべきファイル・フォルダの情報
    Dim HeaderTop As Integer       'ヘッダ部の印刷開始縦位置
    Dim ListTop As Integer         '明細部の印刷開始縦位置
    Dim i As Integer
    Dim HeaderFont As New Font("ＭＳ Ｐゴシック", 14, FontStyle.Regular)
    Dim ListFont As New Font("ＭＳ ゴシック", 12, FontStyle.Regular)
    Dim NameFont As New Font("ＭＳ Ｐゴシック", 12, FontStyle.Regular)

    '▼ヘッダ部

    PageCount += 1
    HeaderTop = e.MarginBounds.Y
    LineLeft = e.MarginBounds.X
    LineHeight = HeaderFont.GetHeight(e.Graphics)

    '印刷対象のフォルダ名を印字。その背景を四角で囲む。
    e.Graphics.FillRectangle(Brushes.LightBlue, New Rectangle(LineLeft, HeaderTop, e.MarginBounds.Width, LineHeight))
    e.Graphics.DrawRectangle(Pens.Black, New Rectangle(LineLeft, HeaderTop, e.MarginBounds.Width, LineHeight))
    e.Graphics.DrawString(txtFolderName.Text, HeaderFont, Brushes.Black, LineLeft, HeaderTop)

    '現在のページ数を印字
    e.Graphics.DrawString(PageCount, HeaderFont, Brushes.Black, LineLeft + e.MarginBounds.Width - 30, HeaderTop)

    '▼明細部

    ListTop = e.MarginBounds.Y + LineHeight + 10
    LineHeight = ListFont.GetHeight(e.Graphics)
    LineTop = ListTop

    For i = PrintPropIndex To FileProps.Count - 1

        Prop = FileProps(i)

        '▼名前 名前はすぐに印字する

        If Prop.IsFolder Then
            Name = CalcString(Prop.Name, NameWidth - 17, e.Graphics, NameFont)
            e.Graphics.DrawImage(ImageList1.Images(0), LineLeft + 1, LineTop)
            e.Graphics.DrawString(Name, NameFont, Brushes.Black, LineLeft + 17, LineTop)
        Else
            Name = CalcString(Prop.Name, NameWidth, e.Graphics, NameFont)
            e.Graphics.DrawString(Name, NameFont, Brushes.Black, LineLeft, LineTop)
        End If

        LineText = ""

        '▼サイズ
        If Settings.IsSize Then
            If Prop.IsFolder Then
                LineText = New String(" ", 14)
            Else
                LineText = Format(Prop.Size \ 1024, "#,0 KB").PadLeft(14)
            End If
        End If

        '▼更新日時
        If Settings.IsLastWriteTime Then
            LineText &= " " & Format(Prop.LastWriteTime, "yyyy/MM/dd HH:mm:ss")
        End If

        '▼作成日時
        If Settings.IsCreationTime Then
            LineText &= " " & Format(Prop.CreationTime, "yyyy/MM/dd HH:mm:ss")
        End If

        '▼属性
        If Settings.IsAttributes Then
            LineText &= " " & Prop.Attributes
        End If

        'この行の情報を印字
        e.Graphics.DrawString(LineText, ListFont, Brushes.Black, LineLeft + NameWidth, LineTop)
        LineTop += LineHeight

        '次の行が印刷可能領域内に入らない場合は次のページの印刷を行う。
        If LineTop + LineHeight > e.MarginBounds.Y + e.MarginBounds.Height Then
            e.HasMorePages = True
            Exit For
        End If

    Next

    '▼明細部全体を四角で囲む

    Dim Rect As New Rectangle(LineLeft, ListTop, e.MarginBounds.Width, LineTop - ListTop)

    e.Graphics.DrawRectangle(Pens.Black, Rect)

    PrintPropIndex = i + 1

    If e.HasMorePages = False Then
        '最後のページの場合はページ数と印刷情報をリセットする。
        'リセットしないと次の印刷がうまくできない。
        PageCount = 0
        PrintPropIndex = 0
    End If

End Sub

'■CalcString
''' <summary>文字列を領域内に入りきるように末尾をカットする</summary>
''' <param name="str">対象の文字列</param>
''' <param name="MaxWidth">領域の幅</param>
''' <param name="g">対象のデバイスコンテキスト</param>
''' <param name="f">使用するフォント</param>
''' <returns>領域内に入りきるようにカットされた文字列</returns>
''' <remarks>できるだけカットする文字数が少なくなるようにする。
''' カットする場合は末尾に「...」を付加する。</remarks>
Private Function CalcString(ByVal str As String, ByVal MaxWidth As Integer, ByVal g As Graphics, ByVal f As Font) As String

    Dim Width As Integer
    Dim TempStr As String
    Dim i As Integer

    For i = Len(str) To 1 Step -1

        TempStr = Strings.Left(str, i)
        Width = g.MeasureString(TempStr, f).Width

        If Width < MaxWidth Then
            If i = Len(str) Then
                Return TempStr
            Else
                Return Strings.Left(str, i - 1) & "..."
            End If
        End If

    Next

    Return ""

End Function

はみ出した部分は別のページにするというのはかなり厄介なプログラムとなってしまいます。今回はあきらめますが、それでもこの印刷機能はなかなか気持ちよくつかえると思います。

    Dim Dialog As New SaveFileDialog

    Dialog.Filter = "CSVファイル(*.csv)|*.csv|すべてのファイル|*.*"
    Dialog.DefaultExt = "csv"

    If Dialog.ShowDialog = Windows.Forms.DialogResult.OK Then
        SaveFileList(Dialog.FileName)
    End If

End Sub

'■SaveFileList
''' <summary>ファイル・フォルダの情報の一覧をcsv形式で保存する</summary>
''' <param name="FileName">保存するcsvファイルのフルパス</param>
''' <remarks>情報はFilePropsコレクションから読み込まれる。
''' FilePropsコレクションに情報をセットするにはReadFileListメソッドを使う。
''' Settingsクラスの設定によって保存する項目が変る。</remarks>
Private Sub SaveFileList(ByVal FileName As String)

    Dim Prop As FileProp
    Dim LineText As String
    Dim Writer As New IO.StreamWriter(FileName, False, System.Text.Encoding.GetEncoding("Shift-JIS"))

    For Each Prop In FileProps

        LineText = Prop.Name & ","

        If Prop.IsFolder Then
            LineText &= "フォルダ" & ","
        Else
            LineText &= "ファイル" & ","
        End If

        'サイズ
        If Settings.IsSize Then
            If Prop.IsFolder Then
                LineText &= "0,"
            Else
                LineText &= Prop.Size \ 1024 & ","
            End If
        End If

        '更新日時
        If Settings.IsLastWriteTime Then
            LineText &= Format(Prop.LastWriteTime, "yyyy/MM/dd HH:mm:ss") & ","
        End If

        '作成日時
        If Settings.IsCreationTime Then
            LineText &= Format(Prop.CreationTime, "yyyy/MM/dd HH:mm:ss") & ","
        End If

        '属性
        If Settings.IsAttributes Then
            LineText &= Prop.Attributes
        End If

        Writer.WriteLine(LineText)

    Next

    Writer.Close()

End Sub

    '▼フォルダとファイルの一覧を表示
    ReadFileList(txtFolderName.Text)
    ShowFileList()

End Sub

    mnuFileSaveAs.Enabled = FileProps.Count > 0
    mnuFilePrint.Enabled = FileProps.Count > 0
    mnuFilePreview.Enabled = FileProps.Count > 0

End Sub

'■[表示]メニュー
Private Sub mnuView_DropDownOpening(ByVal sender As Object, ByVal e As System.EventArgs) Handles mnuView.DropDownOpening

    mnuViewSettings.Enabled = FileProps.Count > 0
    mnuViewRefresh.Enabled = FileProps.Count > 0

End Sub

    mnuFileSaveAs.Enabled = FileProps.Count > 0
    mnuFilePrint.Enabled = FileProps.Count > 0
    mnuFilePreview.Enabled = FileProps.Count > 0

End Sub

    mnuViewSettings.Enabled = FileProps.Count > 0
    mnuViewRefresh.Enabled = FileProps.Count > 0

End Sub

    Dim ClickPath As String

    ClickPath = txtFolderName.Text & lvFiles.SelectedItems(0).Text & "\"

    If IO.Directory.Exists(ClickPath) Then
        txtFolderName.Text = ClickPath
        ReadFileList(txtFolderName.Text)
        ShowFileList()
    End If

End Sub