Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちら をご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


46257 / 76732 ←次へ | 前へ→

【35449】Re:テキストの読み込みについて
回答  Hirofumi  - 06/3/5(日) 0:05 -

引用なし
パスワード
   その2
以下を上記と別な標準モジュールに記述して下さい

Option Explicit

' アクティブなウィンドウのハンドルを取得する関数の宣言
Private Declare Function GetForegroundWindow Lib "user32.dll" () As Long

Public Function GetFolderPath(strPath As String) As Boolean

  Const BIF_RETURNONLYFSDIRS = &H1
  Const ssfDESKTOP = &H0
  Const CSIDL_WINDOWS = &H24
  
  Dim strTitle As String
  Dim objFolder As Object
  Dim hWnd As Long
  
  'アクティブなWindowのハンドルを取得
  hWnd = GetForegroundWindow
  ' 表示タイトルを指定
  strTitle = "フォルダを選択して下さい"
  ' フォルダ選択ダイアログを表示
  Set objFolder = CreateObject("Shell.Application"). _
              BrowseForFolder(hWnd, strTitle, _
                BIF_RETURNONLYFSDIRS, ssfDESKTOP)
  ' フォルダを選択したときは
  If Not (objFolder Is Nothing) Then
    ' 選択フォルダを表示
    With objFolder
      ' 親フォルダが存在するときは
      If Not (.ParentFolder Is Nothing) Then
        ' 選択フォルダのフルパスを表示
        strPath = .Items.Item.Path
      ' 親フォルダのときは
      Else
        ' フォルダ名を表示
        strPath = .Title
      End If
    End With
    ' Folderオブジェクトを破棄
    Set objFolder = Nothing
    '戻り値にTrueを設定
    GetFolderPath = True
  End If
  
  If strPath <> "" And Right(strPath, 1) <> "\" Then
    strPath = strPath & "\"
  End If

End Function

Public Function GetFilesList(vntFileNames As Variant, _
              strFilePath As String, _
              objFso As Object, _
              Optional strNamePattan As String = ".*", _
              Optional strExtePattan As String = ".*") As Boolean

  Dim i As Long
  Dim objFiles As Object
  Dim objFile As Object
  Dim regExten As Object
  Dim regName As Object
  Dim vntRead() As Variant
  Dim strName As String

  'フォルダの存在確認
  If Not objFso.FolderExists(strFilePath) Then
    GoTo Wayout
  End If

  'regExtenpのオブジェクトを取得(正規表現を作成)
  Set regExten = CreateObject("VBScript.RegExp")
  With regExten
    'パターンを設定
    .Pattern = strExtePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With
  Set regName = CreateObject("VBScript.RegExp")
  With regName
    'パターンを設定
    .Pattern = strNamePattan
    '大文字と小文字を区別しないように設定
    .IgnoreCase = True
  End With

  'フォルダオブジェクトを取得
  Set objFiles = objFso.GetFolder(strFilePath).Files

  'ファイルの数が0でなければ
  If objFiles.Count <> 0 Then
    For Each objFile In objFiles
      With objFile
        strName = .Path
        '検索をテスト
        If regExten.test(objFso.GetExtensionName(strName)) Then
          If regName.test(objFso.GetBaseName(strName)) Then
            i = i + 1
            ReDim Preserve vntRead(1 To i)
            vntRead(i) = strName
          End If
        End If
      End With
    Next objFile
  End If

  Set regExten = Nothing
  Set regName = Nothing

  If i <> 0 Then
    vntFileNames = vntRead
    GetFilesList = True
  End If

Wayout:

  'フォルダオブジェクトを破棄
  Set objFiles = Nothing
  Set objFile = Nothing

End Function
6 hits

【35433】テキストの読み込みについて ちび 06/3/4(土) 16:31 質問
【35446】Re:テキストの読み込みについて ponpon 06/3/4(土) 23:02 発言
【35450】Re:テキストの読み込みについて ちび 06/3/5(日) 0:13 お礼
【35448】Re:テキストの読み込みについて Hirofumi 06/3/5(日) 0:04 回答
【35449】Re:テキストの読み込みについて Hirofumi 06/3/5(日) 0:05 回答
【35451】Re:テキストの読み込みについて ちび 06/3/5(日) 0:24 お礼

46257 / 76732 ←次へ | 前へ→
ページ:  ┃  記事番号:
2610219
(SS)C-BOARD v3.8 is Free