Access (VBA)

Access VBAに関するフォーラムです。
  • 掲示板への投稿には会員登録(無料)が必要です。会員登録がまだの方はこちら
  • 掲示板ご利用上のお願い」に反するご記入はご遠慮ください。
  • Q&A掲示板の使い方はこちらをご覧ください
トピックに返信
質問

 
(Windows 7 Professional : Access 2013)
FileSystemObject への書き換えがうまくいきません
投稿日時: 18/04/03 15:39:43
投稿者: KKT

FileSearchで作成された以下のVBAをFileSystemObject に変えて使用しようと思っているのですが、
うまくいきません。(当方素人ですので、説明不足でしたらすみません)
どなたかご教授下さい。
(あるフォルダ内のテキストファイル名を抜き出して、”T_Faile”テーブル内のフィールドに記述する。といった感じかと思います。)
 
Option Compare Database
Option Explicit
 
 
Public Function FaileNameInport(strFolder As String, strKaku As String) As String
Dim RS As Recordset
Dim varFile As Variant
Dim S As String
 
Set RS = CurrentDb.OpenRecordset("T_Faile")
 
CurrentDb.Execute "DELETE T_Faile.* FROM T_Faile;"
 
'ファイリングデータ検索-------------------------------------------------------------
With Application.FileSearch
    .NewSearch
    .LookIn = Application.CurrentProject.path & "\" & strFolder & "\"
    .FileName = "*." & strKaku
    .MatchTextExactly = True
    .SearchSubFolders = False
    If .Execute() > 0 Then
        For Each varFile In .FoundFiles
             S = varFile
             RS.AddNew
             RS!Faile_Name = NameFromPath(S)
             RS.Update
        Next varFile
    End If
End With
 
DoEvents
RS.Close
 
 
End Function
 
どうぞよろしくお願い致します。

回答
投稿日時: 18/04/03 22:14:16
投稿者: i-brown

ADOでこんな感じ。英語の綴りなど若干修正しました。
 
参照設定の追加
・Microsoft ActiveX Data Objects 6.1 Library
・Microsoft Scripting Runtime
 

Public Function FileNameImport(ByVal Directory As String, ByVal Ext As String)
    Dim cn As ADODB.Connection: Set cn = CurrentProject.Connection
    cn.Execute "DELETE * FROM T_File"
    
    Dim rs As New ADODB.Recordset
    rs.Open "T_File", cn, adOpenForwardOnly, adLockPessimistic
    
    Dim fs As New Scripting.FileSystemObject
    EachFolder rs, fs, fs.GetFolder(Application.CurrentProject.Path & IIf(Directory = "", "", "\" & Directory)), Ext
    
    rs.Close
End Function

Private Sub EachFolder( _
        ByRef rs As ADODB.Recordset _
        , ByRef fs As Scripting.FileSystemObject _
        , ByRef fo As Scripting.Folder _
        , ByVal Ext As String)
        
    Dim fi As Scripting.File
    For Each fi In fo.Files
        If fs.GetExtensionName(fi.Name) = Ext Then
            rs.AddNew
            rs.Fields(0) = fi.Path
            rs.Update
        End If
    Next
    DoEvents    ' 1フォルダずつ
    
    ' サブフォルダを検索
    Dim sb As Scripting.Folder
    For Each sb In fo.SubFolders
        EachFolder rs, fs, sb, Ext
    Next
End Sub

トピックに返信