フォルダ名の選択ウィンドウ

今回は、フォルダ名の選択ウィンドウを表示する方法を紹介しますが、少々、上級編になっています。

何故かというと、元々EXCELの機能にはないので、Windows APIといのを使用するからです。

Windows APIというのは、Windowsシステムのあらゆる機能が定義されている低レベルなサブルーチンの集まりです。
低レベルというのは、いわゆる、レベルが低いという意味ではなく、Windwosの基本的な機能を提供するという意味で捉えて下さい。

ですから、EXCELにない機能も実現できちゃたりするのです！
今回は、フォルダ名の選択ウィンドウを表示するのですが、複数のWindowsAPIを利用するので、結構、分かり辛いと思います。

Option Explicit

'InputFolder用
Private Const MAX_PATH            As Long = 260
Private Const BFFM_SETSTATUSTEXTA As Long = &H464&  ' ステータステキスト
Private Const BFFM_ENABLEOK       As Long = &H465&  ' OK ボタンの使用可否
Private Const BFFM_SETSELECTIONA  As Long = &H466&  ' アイテムを選択
Private Const BFFM_INITIALIZED    As Long = &H1&
Private Const BFFM_SELCHANGED     As Long = &H2&
Private Type RECT
        left As Long    'WindowのX座標
        top As Long     'WindowのY座標
        right As Long   'Windowの右端の座標
        bottom As Long  'Windowの底にあたる部分の座標
End Type
Private Type BROWSEINFO
    hWndOwner       As Long     'ダイアログの親ウィンドウのハンドル
    pidlRoot        As Long     'ディレクトリツリーのルート
    pszDisplayName  As String   'MAX_PATH
    lpszTitle       As String   'ダイアログの説明文
    ulFlags         As Long     'ENUM_FLAGS_FOLDER
    lpfn            As Long     'コールバック関数へのポインタ
    lParam          As String   'コールバック関数へのパラメータ
    iImage          As Long     'フォルダーアイコンのシステムイメージリスト
End Type

Public Enum ENUM_ROOT_FOLDER
    CSIDL_DESKTOP = &H0&                        ' デスクトップ
    CSIDL_INTERNET = &H1&                       ' インターネット
    CSIDL_PROGRAMS = &H2&                       ' Program Files
    CSIDL_CONTROLS = &H3&                       ' コントロールパネル
    CSIDL_PRINTERS = &H4&                       ' プリンタ
    CSIDL_PERSONAL = &H5&                       ' ドキュメントフォルダー
    CSIDL_FAVORITES = &H6&                      ' お気に入り
    CSIDL_STARTUP = &H7&                        ' スタートアップ
    CSIDL_RECENT = &H8&                         ' 最近使ったファイル
    CSIDL_SENDTO = &H9&                         ' 送る
    CSIDL_BITBUCKET = &HA&                      ' ごみ箱
    CSIDL_STARTMENU = &HB&                      ' スタートメニュー
    CSIDL_DESKTOPDIRECTORY = &H10&              ' デスクトップフォルダー
    CSIDL_DRIVES = &H11&                        ' マイコンピュータ
    CSIDL_NETWORK = &H12&                       ' ネットワーク(ネットワーク全体あり)
    CSIDL_NETHOOD = &H13&                       ' NETHOOD フォルダー
    CSIDL_FONTS = &H14&                         ' フォント
    CSIDL_TEMPLATES = &H15&                     ' テンプレート
    CSIDL_COMMON_STARTMENU = &H16&              '
    CSIDL_COMMON_PROGRAMS = &H17&               '
    CSIDL_COMMON_STARTUP = &H18&                '
    CSIDL_COMMON_DESKTOPDIRECTORY = &H19&       '
    CSIDL_APPDATA = &H1A&                       '
    CSIDL_PRINTHOOD = &H1B&                     '
    CSIDL_ALTSTARTUP = &H1D&                    '
    CSIDL_COMMON_ALTSTARTUP = &H1E&             '
    CSIDL_COMMON_FAVORITES = &H1F&              '
    CSIDL_INTERNET_CACHE = &H20&                '
    CSIDL_COOKIES = &H21&                       '
    CSIDL_HISTORY = &H22&                       '
End Enum
Enum ENUM_FLAGS_FOLDER
    BIF_RETURNONLYFSDIRS = &H1&          ' フォルダのみ
    BIF_DONTGOBELOWDOMAIN = &H2&         ' ネットワークコンピューターを非表示
    BIF_STATUSTEXT = &H4&                ' ステータス表示
    BIF_RETURNFSANCESTORS = &H8&
    BIF_BROWSEFORCOMPUTER = &H1000&      ' ネットワークコンピューターのみ
    BIF_BROWSEFORPRINTER = &H2000&       ' プリンターのみ
    BIF_BROWSEINCLUDEFILES = &H4000&     ' 全て選択可能
End Enum

Private Declare Function SHBrowseForFolder Lib "shell32" (ByRef lpbi As BROWSEINFO) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" _
        (ByVal pidl As Long, ByVal pszPath As String) As Long
Private Declare Function SendMessageStr Lib "user32" Alias "SendMessageA" _
        (ByVal hwnd As Long, ByVal wMsg As Long, _
         ByVal wParam As Long, ByVal lParam As String) As Long
Private Declare Function SHFree Lib "shell32" Alias "#195" (ByVal pidl As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long

Public Function InputFolder( _
    Optional ByRef strTitle As String = "フォルダーを選択してください", _
    Optional ByVal lngOwnerHwnd As Long = 0&, _
    Optional ByVal lngRoot As ENUM_ROOT_FOLDER = CSIDL_DESKTOP, _
    Optional ByVal lngFlags As ENUM_FLAGS_FOLDER = BIF_RETURNONLYFSDIRS, _
    Optional ByRef strParam As String = vbNullString) As String

    On Error GoTo Err_InputFolder:

    Dim biParam     As BROWSEINFO
    Dim pidl        As Long
    Dim strPath     As String

    If lngOwnerHwnd = 0& Then
        lngOwnerHwnd = GetDesktopWindow()
    End If

    strPath = String$(MAX_PATH, vbNullChar)

    With biParam
        .hWndOwner = lngOwnerHwnd
        .pidlRoot = lngRoot
        .pszDisplayName = strPath
        .lpszTitle = strTitle & vbNullChar
        .ulFlags = lngFlags
        If Len(strParam) > 0& Then
            
            .lpfn = GetLong(AddressOf BrowseCallbackProc)
            .lParam = strParam & vbNullChar
        End If
    End With

    pidl = SHBrowseForFolder(biParam)

    If biParam.ulFlags And BIF_BROWSEFORCOMPUTER Then
        strPath = biParam.pszDisplayName
        strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
    Else
        If pidl = 0& Then
            strPath = vbNullString
        Else
            If SHGetPathFromIDList(pidl, strPath) <> 0& Then
                strPath = left$(strPath, InStr(strPath, vbNullChar) - 1&)
            Else
                strPath = vbNullString
            End If
        End If
    End If

    Call SHFree(pidl)
    InputFolder = strPath
Exit_InputFolder:
    Exit Function

Err_InputFolder:
    InputFolder = vbNullString
    Resume Exit_InputFolder:
End Function

'
'   SHBrowseForFolder API のコールバック関数。
'
Private Function BrowseCallbackProc(ByVal lngHWnd As Long, ByVal lngUMsg As Long, _
                            ByVal lngLParam As Long, ByVal lngLpData As String) As Long
    Select Case lngUMsg
        Case BFFM_INITIALIZED
            Call SendMessageStr(lngHWnd, BFFM_SETSELECTIONA, 1&, StrConv(lngLpData, vbUnicode))
        'Case BFFM_SELCHANGED
        ' ITEMが選択された時に処理を行いたい場合ここに書きます
    End Select
    BrowseCallbackProc = 0&
End Function

Private Function GetLong(varAddr As Variant) As Long
    GetLong = CLng(varAddr)
End Function

フォルダ名の選択ウィンドウを表示するGetFolderNameの使用方法は、次回、紹介します。

それでは！

ファイル一覧取得

今日は、あるフォルダー配下のサブフォルダーも含めたファイル一覧を取得します。

今回は、サブルーチンからサブルーチンを呼んでいます。
又、サブルーチンが自分自身を呼んでいますが、これを再帰呼び出しと呼びますが、これにより、プログラムが単純化され、行数も少なくてすみます。

GetFilesサブルーチンには、フォルダー名とファイルパターン（例では、EXCELファイルだけを取得する為に、*.xlsとしています）を指定すると、その条件に合致したファイル名一覧をシートの11行目以降に表示します。

Public Sub ファイル一覧取得()
  On Error Resume Next
  Dim wFiles() As String
  Dim i As Integer
  Dim wFolder As String
  wFolder = "C:\Documents and Settings\azukei\My Documents\EXCELツール"
  'ファイル一覧取得サブルーチンを呼ぶ
  Call GetFiles(wFolder, "*.xls", wFiles())
  '13行目以降を選択する
  Range(Cells(13, 1), ActiveCell.SpecialCells(xlLastCell)).Select
  '選択したエリアをクリアする
  Selection.ClearContents
  '11行目1列目にフォルダー名をセットする
  Cells(11, 1) = wFolder
  '13行目より、取得したファイル名をセットする
  For i = 0 To UBound(wFiles)
      Cells(i + 13, 1) = wFiles(i)
  Next
  Cells(1, 1).Select
End Sub

Public Sub GetFiles(ByVal pFolder As String, ByVal pPattern As String, ByRef pFiles() As String)
  On Error Resume Next
  Dim i As Integer
  Dim wFile As String
  Dim wSubFolder As String
  '配列（pFiles）の最大インデックスを取得する
  i = UBound(pFiles)
  'フォルダー内の最初のファイルを取得する
  wFile = Dir(pFolder & "\" & pPattern, vbNormal)
  Do Until wFile = ""
     '配列の要素数を動的に変更する
     ReDim Preserve pFiles(i)
     pFiles(i) = pFolder & "\" & wFile
     i = i + 1
     'フォルダー内の次のファイルを取得する
     wFile = Dir
  Loop
  'フォルダー内の最初のサブフォルダーを取得する
  wSubFolder = Dir(pFolder, vbDirectory)
  Do Until wFile = ""
     '自分自身のサブルーチンを呼ぶ（再帰呼び出し）
     Call GetFiles(wSubFolder, pPattern, pFiles())
     'フォルダー内の次のサブフォルダーを取得する
     wSubFolder = Dir
  Loop
End Sub

今日はここまで！

それでは！

ファイル行数集計

今日は、ファイルの行数集計です。

非常にシンプルなサブルーチンです。

Public Sub 行数集計()
  Dim Rtn As Integer
  Dim wFNo As Integer
  Dim wCnt As Integer
  Dim wRec As String
  '実行確認メッセージ
  Rtn = MsgBox("行数集計を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Input As #wFNo
  wCnt = 0
  'ループ（繰り返し）の開始
  Do Until EOF(wFNo)
     'ファイルから1行読み込む
     Line Input #wFNo, wRec
     wCnt = wCnt + 1
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox wCnt & "行ありました。", vbInformation + vbOKOnly
End Sub

それでは！

CSVファイル入力 その２

今回は、もう一つのCSVファイル入力方法です。

前回は、Line Input文で、1行分読み込んでから処理しましたが、今回は、Input文を使用して、カンマで区切られた内容を1項目づつ取り出すやり方です。
今回のやり方は、予め1行に何項目あるかが分かっている場合に使えますね！

Public Sub CSV入力2()
  Dim Rtn As Integer
  Dim i As Integer
  Dim j As Integer
  Dim wFNo As Integer
  Dim wCell(3) As String
  '実行確認メッセージ
  Rtn = MsgBox("CSV入力を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Input As #wFNo
  i = 0
  'ループ（繰り返し）の開始
  Do Until EOF(wFNo)
     i = i + 1
     '1行をカンマ区切りで、1項目づつ入力する
     Input #wFNo, wCell(1), wCell(2), wCell(3)
     For j = 1 To 3
         Cells(i, j) = Replace(wCell(j), Chr$(34), "")
     Next
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox "CSV入力が終了しました。", vbInformation + vbOKOnly
End Sub

それでは！

CSVファイル入力

今回は、CSVファイルを呼んで、シートに表示するサブルーチンについてです。

EXCELは、CSVファイルをダブルクリックすると、ちゃんと表示してくれますから、この機能はあまり意味がないですね！
CSVファイルの入力方法には、2つありますが、今回は、Line Input文を使って、1行分づつ読み込んでから、カンマで分離して、さらに、ダブルクオーテーションを取り除く方法を紹介します。

Public Sub CSV入力1()
  Dim Rtn As Integer
  Dim i As Integer
  Dim j As Integer
  Dim wFNo As Integer
  Dim wRec As String
  Dim wCell() As String
  '実行確認メッセージ
  Rtn = MsgBox("CSV入力を実行しますか？", vbQuestion + vbYesNo)
  If Rtn = vbNo Then
     Exit Sub
  End If
  'ファイル番号を取得する
  wFNo = FreeFile
  'CSVファイルをOPENする
  Open "C:\計算.csv" For Input As #wFNo
  i = 0
  'ループ（繰り返し）の開始
  Do Until EOF(wFNo)
     i = i + 1
     'ファイルから1行読み込む
     Line Input #wFNo, wRec
     'カンマで区切られた内容を分離して、配列にセットする
     wCell = Split(wRec, ",")
     For j = 0 To 2
         'ダブルクオーテーション（Chr$(34)）を空値へ置換する
         wCell(j) = Replace(wCell(j), Chr$(34), "")
         Cells(i, j + 1) = wCell(j)
     Next
  'ループの終了
  Loop
  'ファイルをクローズする
  Close
  '実行結果確認メッセージ
  MsgBox "CSV入力が終了しました。", vbInformation + vbOKOnly
End Sub

今日は、ここまでです。

次回は、もう一つのCSV入力方法について紹介します。

それでは！

海外ドラマについて

私は、かなり以前から、スカパーで海外ドラマを見ています。

基本的には、先が読めないストーリー性の高い作品が好きですが、中でもSFは発想が自由で、奇想天外なストーリーが多いです。

以前は、スタートレックシリーズが好きでしたが、最近では、スターゲイトやLostが気に入っています。

スタートレックは、スタートレック、新スタートレック、スタートレック・DS9、スタートレック・ボイジャー、スタートレック・エンタープライズと5シリーズもあり、全部あわせると数百話あります。
そのうちのほとんどの作品を見ていて、又、再放送も何度も見ているので、最近は少々、飽きてきています。

スターゲイトは、シーズン10まであって、世界最長ドラマになっていますが、スピンアウト作品であるスターゲイト・アトランティスもシーズン3まであります。
両作品とも、質が高く、特撮やストーリ性が抜群で、これも、再放送を何度も見ています。

Lostは、上記作品とは違って、舞台は地球上の現代なのですが、飛行機が南の孤島に墜落して、生き残った人達と島の不思議な力との葛藤を描く、ミステリアスな作品ですが、これも、再放送を何度見ています。
やっと、7月からLost5が始まりますが、今度、頻繁にタイムスリップが起きるみたいです。

私にとって、良いドラマとは、何度も再放送を見ても大丈夫な作品ということになります。

みなさんは、如何でしょうか？

それでは！

PCの話

皆さんは、どんなPCを使用していますか？

デスクトップですか？ノートPCですか

私の自宅には、デスクトップ3台（1台故障）、ノート4台（1台故障）と、家族4人に対して、人数分以上あります。

最近まで、デュアルコアのデスクトップを使用していましたが、音と電気代が気になりだして、オークションでノートPCを2万円台で入手して、使用しています。

昔のノートPCは、壊れやすく高かったのですが、今はそんな事はありません。
SPECは、PentiumMの1.6GHｚでメモリは512KBだったのを、数千円で中古の2GBメモリに乗せ変えました。

今まで使っていたデスクトップよりも、性能は落ちますが、音が静かで、電気もあまり使っていない感じがして、エコな気分です。

私は、PC上でいろいろな事をしているので、かなりハードな使い方をしていますが、上記のSPECでほとんど問題ありません。
OSはXPのSP3ですが、Vistaにすると、かなり遅くなるでしょうね！

でも、もうすぐ発売になるWindows7は、見た目はVistaに近いですが、かなり早くなっているみたいです。デスクトップマシーンにベータ版をインストールをして、動かしてみたのですが、かなり、早く感じました。

ですから、家族の誰かがPCが欲しいといったら、ショップにいって、十万円以上のPCを買っては駄目です。
中古でいいなら、結構性能のいいノートPCが、高くても3万円で手に入ります。
運が良ければ、2万円台で手に入ります。

今日は、ここまで！