[[20150419182815]] 『フォルダ内のファイルを一覧表示してハイパーリンクを貼』(尾張生まれ) ページの最後に飛ぶ

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『フォルダ内のファイルを一覧表示してハイパーリンクを貼る』(尾張生まれ)

宜しくお願いします。
EXCEL2010です。
数年前にこの学校で掲載されていた構文を見つけ職場で活用
させて頂いておりました。
古いPCは2003で動いている為そのまま使っておりましたが
新しいPC(2010)で動かしたところエラーが出ました。
下記の構文で●のところでエラーとなります。
エラー「実行時エラー445
オブジェクトは動作をサポートしていません。
です。

対処方法はあるでしょうか。
こういう質問の方法はいけないのかもわかりませんが

宜しくお願いします

Sub ListFilePath()
'指定されたフォルダ配下のファイル一覧のハイパーリンクを、
'新規シートに書き出す
'サブフォルダは、"\" で表示する
'拡張子が、".exe", ".com" のファイルはリンクを除外する
'Sort_Asc() 関数使用 2010/07/24 pPoy

    Dim objFSO As Object                    'FileSystemObject
    Dim objFile As Object                   'File

    Dim myFolder As String                  'パス格納
    Dim mySearchName As String              '検索条件格納
    Dim myFileName() As String              'ファイル名用
    Dim myFolderName() As String            'フォルダ名格納
    Dim myFullPath() As String              'フルパス格納

    Dim CntR As Long                        '記述開始行番号
    Dim CntC As Long                        '記述開始列番号
    Dim tmpName As String
    Dim tmpPath As String
    Dim i As Long, fCnt As Long

    mySearchName = "*.*"                    '★検索条件:全ファイル
        myFolder = ThisWorkbook.Path
   '★検索対象フォルダ
    CntR = 1                                '1行目から書き出し
    CntC = 2                             'B列から
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    'ワークシートを先頭に追加(現在のシートに出力に変更)
   ' Worksheets.Add before:=Sheets(1)
    'Webオプション設定変更(ハイパーリンクの絶対パスを保存するため)
   ' With Application.DefaultWebOptions
   '     .UpdateLinksOnSave = False
   ' End With

    'シートに出力開始
    With ActiveSheet
        .Cells(CntR, CntC).Value = _
                "処理日: " & Format(Now, "yyyy/mm/dd (aaa) hh:mm")
      '  .Cells(CntR + 1, CntC).Value = _
                "検索条件: " & mySearchName  ’■自主変更 ホルダ-までのフルパスを表示
        .Cells(CntR + 1, CntC).Value = _
               "フォルダまでのフルパス: " & myFolder    '■自主変更 ”ホルダ-までのフルパス: ”を表示

       ' .Cells(CntR + 2, CntC).Value = _    ’■自主変更 ホルダ-までのフルパスを表示
       '         "対象フォルダ: " & myFolder ’■自主変更  検索条件: *.*

         .Cells(CntR + 2, CntC).Value = "フォルダ名:" & Dir(ActiveWorkbook.Path, vbDirectory)  '■自主変更 ホルダ-のみを表示

    '検索開始
    With Application.FileSearch ●ここでエラーになります
        .NewSearch                          '前回の条件をクリア
        .FileType = msoFileTypeAllFiles     'すべてのファイル
        .LookIn = myFolder                  '検索フォルダ指定
        .SearchSubFolders = True            'サブフォルダ含む
        .Filename = mySearchName
        If .Execute() > 0 Then
            fCnt = .FoundFiles.Count        '件数
            ReDim myFileName(fCnt)
            ReDim myFolderName(fCnt)
            ReDim myFullPath(fCnt)

            'ファイル名のフルパス取得
            For i = 1 To fCnt
                'フルパス格納
                myFullPath(i) = .FoundFiles(i)
                'パス以外のファイル名取得
                Set objFile = objFSO.GetFile(.FoundFiles(i))
                myFileName(i) = objFSO.GetFileName(objFile)

                'フォルダ名セット
                tmpPath = objFSO.GetParentFolderName(objFile)
                If myFolder <> tmpPath Then
                    myFolderName(i) = Mid(tmpPath, Len(myFolder) + 2) & "\"
                    'サブフォルダ+ファイル名
                    myFileName(i) = myFolderName(i) & myFileName(i)
                End If
            Next i

            'フルパスをソート
            Call Sort_Asc(myFullPath())
            DoEvents
            '表示名をソート
            Call Sort_Asc(myFileName())
            DoEvents

            '追加したシートに転記

            Range("A7").Select

            With ActiveSheet
                .Cells(CntR + 3, CntC).Value = _
                        "検索件数: " & fCnt - 1 & " ファイル"  '実際のファイル数ー1 目次ファイル(このファイル)を集計の対象外とする
                For i = 1 To fCnt
                    .Cells(CntR + 4 + i, CntC).Value = _
                        myFileName(i)
                    tmpName = Right(myFileName(i), 3)
                    '★実行形式ファイル以外はハイパーリンク設定
                    If Not (tmpName = "exe" Or tmpName = "com") Then
                        .Hyperlinks.Add _
                            Anchor:=.Cells(CntR + 4 + i, CntC), _
                            Address:=myFullPath(i), _
                            TextToDisplay:=myFileName(i)
                    End If
                Next i
            End With
            MsgBox "フォルダ内のファイル数: " & fCnt - 1 & "件です", vbOKOnly '実際のファイル数ー1 目次ファイル(このファイル)を集計の対象外とする
            Set objFile = Nothing

        Else
            '無し
            ActiveSheet.Cells(CntR + 3, CntC).Value = _
                "ファイルが見つかりませんでした"
            MsgBox "ファイルが見つかりませんでした", vbOKOnly

        End If
    End With
    End With
    Set objFSO = Nothing

End Sub

< 使用 Excel:unknown、使用 OS:unknown >


 FileSearch が2007 から無くなっているためだと思いますので、代替クラスを置くなどで
 対応してはどうでしょうか。

 下記に情報があるかと思いますので、確認ください。

[[20150401123111]] 『EXCEL2007での FileSearch 問題』(疑問者)

(Mook) 2015/04/19(日) 19:16


 Mookさん
 有難うございました。
 困っていたら同僚にこのサイトを教えてもらって「聞いてみたら」 
 とのアドバイスを得て投稿しました。
 マクロは全く分からず、EXCELはただ使うだけのスキルです。
 ご回答の内容全くわかりません。
 もしよろしければ ,具体的にどうづればいいか教えて頂け
 ないでしょうか(尾張生まれ)


 下記から FileSearchBook.xls をダウンロードして開き、ALT+F11 で VBE を起動して、
 クラスモジュールから FileSearchClass を右クリックしてファイルのエクスポートで
 FileSearchClass.cls を保存し、FileSearchBook.xls を終了。
http://d.hatena.ne.jp/xixiixiiixiv/20120806/1344258369

 今回の問題のファイルを開いて、同じく VBE を起動して問題のファイルで右クリック
 してファイルのインポートで、保存した FileSearchClass.cls ファイルを読み込み。

 後は参照先にあるようにエラーの出た、
    With Application.FileSearch
 を
    With New FileSearchClass
 に変更。

 としてみてください。
(Mook) 2015/04/19(日) 21:48


 Mookさん、有難うございます。
 教えて頂いたものをひらいたら下記の構文があらわれました。
 GetFileList("c:\")
 GetFileList2007("c:\")

 Alt + F11 でVBEを開き、
イミディエイトウィンドウにて以下を実行
 GetFileList("c:\")
 GetFileList2007("c:\")

 >クラスモジュールから 
 はどうやって接続すればいいでしょうか
 手取り足取りの質問になりましたが
 宜しくお願いします。
 (尾張生まれ)

 


 いやいや、シートに書いてあることは気にしないで、先の説明通りにしてください。
 やりたいのは FileSearch の替わりになるコードを取り出して、利用することだけなので、
 コードを保存したらダウンロードしたファイルは用済みです。

 GetFileList ほにゃららは無視してください。

(Mook) 2015/04/19(日) 22:39


 Mookさん、有難うございます。
 正直言ってなにをどうすればいいのかわかりません。
 紹介して頂いた
http://d.hatena.ne.jp/xixiixiiixiv/20120806/1344258369に接続したあと
 どうすればいいでしょうか
 すみません、再度手取り足取りの質問になりますが
 宜しくお願いします。(尾張生まれ)


  FileSearchBook.xls で VBE を開いたら、左側にクラスモジュール があります。
 そこに FileSerachClass がありますから、右クリックで「ファイルのエクスポート」です。
http://www.asahi-net.or.jp/~zn3y-ngi/YNxv9d1.html

 読み込みは、エラーが出ているファイルのクラスモジュールで右クリックから
 「ファイルのインポート」です。 

(Mook) 2015/04/19(日) 23:04


 ファイルのインポート、エクスポートの手順です。
 http://officetanaka.net/excel/vba/tips/tips112c.htm

 検索してもなおわからないのかもしれませんが、ネットがとても便利な時代です。
 EXCEL だけでなく検索スキルの向上も目指してはどうかと思います。
(Mook) 2015/04/20(月) 09:14

 Sub test()
    Dim FSO As Object
    Dim cFiles As Variant
    Dim cPath As String
    Dim i As Long
    Dim iSt As Long

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set FSO = CreateObject("Scripting.FileSystemObject")

    cPath = ActiveWorkbook.Path & "\"
    iSt = Len(cPath) + 1
    cFiles = Split(CreateObject("WScript.Shell").Exec("CMD /C DIR /A:-D/B/S """ & cPath & "*.*""").StdOut().ReadAll(), vbNewLine)
    For i = 0 To UBound(cFiles) - 1
        ActiveSheet.Hyperlinks.Add Anchor:=Cells(i + 6, "B"), Address:=cFiles(i), TextToDisplay:=Mid(cFiles(i), iSt)
    Next i

    Set FSO = Nothing

    Range("B1") = "処理日: " & Format(Now, "yyyy/mm/dd (aaa) hh:mm")
    Range("B2") = "フォルダまでのフルパス: " & ActiveWorkbook.Path
    Range("B3") = "フォルダ名:" & Dir(ActiveWorkbook.Path, vbDirectory)
    Range("B4") = "検索件数: " & UBound(cFiles) & " ファイル"

    With ActiveSheet.Sort
        .SetRange Range("B6:B" & UBound(cFiles) + 6)
        .Header = xlGuess
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
 End Sub
(???) 2015/04/20(月) 09:24

あ、EXEとCOMの場合はリンク不要な部分を入れ忘れ。そこはまぁ、応用してください。
(???) 2015/04/20(月) 09:27


 宜しくお願いします。
です。
 ご返事が遅くなりました.申し訳けありません。

 ???さん、作って頂いた構文実行しました。
 フォルダ直下のファイル一覧や2次フォルダ内のファイルの場合は
 パスの形式で表示することが出来ました。
 有難うございました。

 Mookさん
 教えて頂いた方法の手順がなかなか理解できず時間がかかっておりました。
 結果
 作成中のファイルのクラスモジュールにFileSearchClasscls いうのが出来
 下記の構文が入りました。
 Option Explicit

' FileSearch再現クラス
' Office2007以降使用不可となっているFileSearchを再現するクラス
' 「Microsoft Scripting Runtime」を参照設定に指定する

' プロパティ扱い
Public LookIn As String ' 検索先
Public FileName As String ' 検索条件
Public SearchSubFolders As Boolean ' サブフォルダの検索

'Private変数

 Private poFSO As FileSystemObject

' 検出されたファイルのフルパスコレクション
Private poFoundFiles As Collection
Public Property Get FoundFiles() As Collection

    If poFoundFiles Is Nothing Then
        Set poFoundFiles = New Collection
    End If
    Set FoundFiles = poFoundFiles
End Property

Public Sub NewSearch()

    LookIn = Application.StartupPath
    FileName = "*.*"
    SearchSubFolders = False
End Sub

' 検索実行
Public Function Execute() As Long
On Error GoTo ABORT

    Set poFoundFiles = New Collection
    Set poFSO = New FileSystemObject
    If Right(LookIn, 1) <> "\" Then LookIn = LookIn & "\"     ' 末尾\記号強制
    Call runSearch(LookIn)
OK:
    Execute = poFoundFiles.Count
    GoTo FINALLY
ABORT:
    Execute = 0
    Call MsgBox(Err.Number & ":" & Err.Description)
FINALLY:
    Set poFSO = Nothing
End Function

' 検索処理詳細
Private Sub runSearch(sArgSearchPath As String)

    Dim oFolder As Folder
    Set oFolder = poFSO.GetFolder(sArgSearchPath)

    ' サブフォルダに潜る
    If SearchSubFolders Then
        Dim oSubFolder As Folder
        For Each oSubFolder In oFolder.SubFolders
            runSearch (oSubFolder.Path)
        Next
    End If

    ' 全ファイル抽出
    Dim oFile As File
    For Each oFile In oFolder.Files
        If Not (oFile.Name Like FileName) Then GoTo CONTINUE ' 処理対象外を除外
        Call poFoundFiles.Add(oFile.Path) ' コレクションに登録
CONTINUE:
    Next
End Sub

 >後は参照先にあるようにエラーの出た、
 >   With Application.FileSearch
 >を
 >  With New FileSearchClass
 >に変更 
 ということで変更しました。

 再度、マクロを事項しました。

 再度エラーで
 コンパイルエラー
 ユーザー定義型は定義されていません と表示されました

 'Private変数
 Private poFSO As FileSystemObject ★ここでエラーのようです。

 何か手順が違うのでしょうか。
 よろしければ 教えて下さい。
 宜しくお願いします。(尾張生まれ)

 


  Private poFSO As FileSystemObject ★ここでエラーのようです。
 でエラーが出るということは、
' 「Microsoft Scripting Runtime」を参照設定に指定する 
 をしていないのではないでしょうか。

http://www.relief.jp/itnote/archives/fso-vba-references.php

(Mook) 2015/04/29(水) 18:35


 Mookさん、早速のご返事有難うございます。
 時間がかかると思いますが、確認してやってみます。
 有難うございます。  (尾張生まれ)


 Mookさん。上記確認できました。
 「Microsoft Scripting Runtime」にレをいれました。
 マクロ再実行で

 .FileType = msoFileTypeAllFiles     'すべてのファイル
 のところで
 コンパイルエラー
 メゾットまたはデータメンバーがみつかりません。 となりました。
 どうすればいいいで」しょうか 
 聞いてばかりですみません。(尾張生まれ)


 代替クラスに FileType プロパティはないようなので、その行は削除してみてください。

(Mook) 2015/04/29(水) 20:44


 お〜! 動きました。Mookさん 有難うございました。
 旧PCで動いていた4ものが新PCで動かないことがある!
 そんなことがあるのですね。
 旧PCには先人が作ったマクロがたくさんあるのですが
 新PCでは使えないマクロがあると思うと心配です。
 また、困ったらこの学校に質問させて頂きます。
 ご丁寧な回答有難うございました。
 (尾張生まれ) 2015/04/29(水) 22:25


コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.