VBA to list name & path of all open documents

[Derek]

Hi Folks

Can anyone help with code that will list in an Excel worksheet, the names and paths of all open documents - both MS Excel and MS Word.

I have this code but it only works for Excel workbooks:

Sub ExcelFilesOpen()
Application.EnableEvents = True
Dim str1 As String
str1 = ActiveSheet.Name
For Each Workbook In Application.Workbooks
ThisWorkbook.Sheets(str1).Range("B65536").End(xlUp).Offset(1, 0).Value = Date
ThisWorkbook.Sheets(str1).Range("B65536").End(xlUp).Offset(0, 1).Value = Time
ThisWorkbook.Sheets(str1).Range("B65536").End(xlUp).Offset(0, 2).Value = Workbook.Name
ThisWorkbook.Sheets(str1).Range("B65536").End(xlUp).Offset(0, 3).Value = Workbook.Path
Next
End Sub

The listed files are then opened by a right click event macro:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Application.ScreenUpdating = False
If Target.Cells.Count <> 1 Then Exit Sub
If Target.Column <> 2 And Target.Column <> 4 Then Exit Sub
If Target.Row < 4 Then Exit Sub
Cancel = True
If Target.Column = 2 Then
ActiveSheet.Unprotect
Target.EntireRow.Delete
ActiveSheet.Protect
Exit Sub
End If
If Target.Column = 4 Then
Dim fn As String
fn = Target.Offset(0, 1).Value & "\" & Target.Value
On Error Resume Next
Workbooks.Open FileName:=fn
End If
End Sub


Many thanks
Derek

 

[Case_Germany]

Hi,

a possibility for open Word documents:

In e. g. Sheet1:

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, _
    ByVal nshowcmd As Long) As Long

Private Const SW_MAXIMIZE = 3 ' Open maximised

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Value = "" Then Exit Sub
    ShellExecute 0, "open", Target.Offset(0, 1).Value & "\" & Target.Value, "", "", SW_MAXIMIZE
End Sub

In a module:

Sub Word_List()
    Dim oApp As Object
    Dim intCount
    Set oApp = GetApplication("Word.Application")
    If oApp Is Nothing Then
        MsgBox "No document!"
        Exit Sub
    End If
    With oApp
        For intCount = 1 To .Documents.Count
            Cells(intCount, 1).Value = .Documents(intCount).Name
            Cells(intCount, 2).Value = .Documents(.Documents(intCount)).Path
        Next intCount
    End With
    Set oApp = Nothing
End Sub

Private Function GetApplication(ByVal AppClass As String) As Object
    Const vbErr_AppNotRun = 429
    On Error Resume Next
    Set GetApplication = GetObject(Class:=AppClass)
    If Err.Number = vbErr_AppNotRun _
        Then Set GetApplication = CreateObject(AppClass)
    On Error GoTo 0
End Function

Case_Germany

 

[Derek]

Hi Case_Germany

Absolutely brilliant!
That is exactly what I was looking for.

Thanks so much, this is going to save me a lot of trouble and time

Have a great day

Regards

Derek

 

[Case_Germany]

Hi again,

Have a great day

Thanks and you too - have a great day.

Case_Germany

 

[tamer42]

Hi,

a possibility for open Word documents:

In e. g. Sheet1:

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal Hwnd As Long, ByVal lpOperation As String, ByVal lpFile As String, _
    ByVal lpParameters As String, ByVal lpDirectory As String, _
    ByVal nshowcmd As Long) As Long

Private Const SW_MAXIMIZE = 3 ' Open maximised

Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
    If Target.Value = "" Then Exit Sub
    ShellExecute 0, "open", Target.Offset(0, 1).Value & "\" & Target.Value, "", "", SW_MAXIMIZE
End Sub

In a module:

Sub Word_List()
    Dim oApp As Object
    Dim intCount
    Set oApp = GetApplication("Word.Application")
    If oApp Is Nothing Then
        MsgBox "No document!"
        Exit Sub
    End If
    With oApp
        For intCount = 1 To .Documents.Count
            Cells(intCount, 1).Value = .Documents(intCount).Name
            Cells(intCount, 2).Value = .Documents(.Documents(intCount)).Path
        Next intCount
    End With
    Set oApp = Nothing
End Sub

Private Function GetApplication(ByVal AppClass As String) As Object
    Const vbErr_AppNotRun = 429
    On Error Resume Next
    Set GetApplication = GetObject(Class:=AppClass)
    If Err.Number = vbErr_AppNotRun _
        Then Set GetApplication = CreateObject(AppClass)
    On Error GoTo 0
End Function

Case_Germany

Hi,

I'm looking for open Text Files (*.txt)

list name & path of all open Text Files (*.txt)

best Regards

 

[pappiloo]

Hi again,



Thanks and you too - have a great day.

Case_Germany

Can you explain to a newbie how to do the one for Word and Powerpoint please?
Many Thanks