Open all files in a folder (Different types: VBA, excel, word)-CodePudding

I am trying to make a VBA code that loops through all the files in my folder. The folder has different files which include .vbs, .doc,.pdt etc. I have a code that opens everything in a workbook but wont work to open them in their correct format. I tried different shell functions but that didnt work either.

Sub Looping()
'Step 1:Declare your variables
    Dim MyFiles As String
'Step 2: Specify a target folder/directory, you may change it.
    MyFiles = Dir("C:\Users\path of folder\")
    Do While MyFiles <> ""
'Step 3: Open Workbooks one by one
    Workbooks.Open "C:\Users\path of folder\" & MyFiles

    ActiveWorkbook.Activate
    'run some code here
    Application.Wait (Now   TimeValue("0:00:10"))
    
    ActiveWorkbook.Close SaveChanges:=True

'Step 4: Next File in the folder/Directory
    MyFiles = Dir

    Loop
End Sub

Any help would be appreciated

CodePudding user response：

Please, try the next updated sub. It will use the known applications for workbooks or Word documents to open/close them and FollowHyperlink to open the rest of extensions in their default application, then find their application process and terminate it.

Edited: In order to avoid that waiting sign I changed Application.Wait (Now TimeValue("0:00:10")) with Sleep API. Please, firstly copy the next API function on top of the module keeping the code (in the declarations area):\

 Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

Then, the next updated code in the same module:

Sub Looping()
    Dim MyFiles As String, folderPath As String, strExt As String, wb As Workbook
    folderPath = ThisWorkbook.Path & "\TestCSV\"
    MyFiles = Dir(folderPath & "*.*")
    Do While MyFiles <> ""
        strExt = Split(MyFiles, ".")(1)
        Select Case LCase(strExt)
            Case "xls", "xlsx", "xlsm", "xlsb", "csv"
                Set wb = Application.Workbooks.Open(folderPath & MyFiles)
            Case "doc", "docx", "docm"
                Dim appWord As Word.Application, doc As Object
                Set appWord = CreateObject("Word.Application")
                appWord.Visible = True
                Set doc = appWord.Documents.Open(folderPath & MyFiles)
            Case Else
               ActiveWorkbook.FollowHyperlink folderPath & MyFiles
      End Select
       DoEvents
         Sleep 5000 'for 5 seconds, 10000 for 10 seconds
         'Application.Wait (Now   TimeValue("0:00:5"))
       DoEvents
      Select Case LCase(strExt)
            Case "xls", "xlsx", "xlsm", "xlsb", "csv"
                wb.Close False
            Case "doc", "docx", "docm"
                doc.Close: appWord.Quit
            Case Else
                Dim exeApp As String
                exeApp = GetApplication("." & strExt)
                TerminateProcess exeApp 'it terminates the whole process.
                                                  'for a pdf file, even if some more files were open in Acrobat
                                                  'all files will also be closed when process is terminated...
      End Select
      
    MyFiles = Dir  'continue the loop
    Loop
End Sub

The other necessary functions:

Private Function GetApplication(ext As String) As String
   Dim strAppl As String, strPathExe As String, strExeFile As String, strODSfile As String
    Dim WSHShell As Object

    Set WSHShell = CreateObject("WScript.Shell")
    On Error Resume Next
    strAppl = WSHShell.RegRead("HKEY_CLASSES_ROOT\" & WSHShell.RegRead("HKEY_CLASSES_ROOT\" & ext & "\") & _
                                                                                  "\shell\open\command\")
    If err.Number <> 0 Then
        err.Clear: On Error GoTo 0
        GetApplication = ""
        MsgBox "No program installed for extension """ & ext & """"
        Exit Function
    End If
    On Error GoTo 0
    strExeFile = Split(strAppl, """ """)(0)
    strExeFile = Right(strExeFile, Len(strExeFile) - 1)
    strExeFile = Right(strExeFile, Len(strExeFile) - InStrRev(strExeFile, "\"))
    GetApplication = strExeFile
End Function

Private Sub TerminateProcess(sExeName As String)
   Dim strComputer As String, objWMIService As Object, colItems As Object, objItem As Object
    strComputer = "."
    
    Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2")
    Set colItems = objWMIService.ExecQuery("SELECT * FROM Win32_Process WHERE Name = '" & sExeName & "'", , 48)
    
    For Each objItem In colItems
      objItem.Terminate
    Next
End Sub

There also are extensions (like .txt) for which the process cannot be returned in the above tried way. I think I can also find a way to determine the application window handler (based on its title containing the file name) and then extract the process from the window handler. But it is complicated and if you do not use text files, it will be a lot of useless work...

The code is not tested, but it should work. If a problem, I probably missed something minor, typos etc. In such a case do not hesitate to ask for clarifications, mentioning the error or whichever inconvenience you have.