this is my first question so I would love to improve my style and such. Just tell me if I am doing something completely wrong.
My question: I am searching files with a specific extensions. All results get printed to excel and then create shortcuts to each file which get then stored in a folder. This works perfectly fine for now, but I need the shortcut to include the author detail to filter all entries (hundreds to thousends) for it. The result should be a shortcut with the same properties that you get when using the 'create shortcut' from context menu vie right click.
I hope you can help my since I am trying to get this to work for a while now.
If you know a solution, that does what I need but is maybe written in a different language that is fine for me as long as the user does not have to install runtimes/libraries (sory I am a complete beginner)
'This function searches for files with endings (ppt,pptx,pptm) and pastes the found entries into the excel sheet
Function Recurse(sPath As String) As String Dim FSO As New FileSystemObject Dim myFolder As Folder Dim mySubFolder As Folder Dim myFile As File Set myFolder = FSO.GetFolder(sPath) Set Extensions = CreateObject("Scripting.Dictionary") Extensions.CompareMode = 1 ' make lookups case-insensitive 'Extensions.Add Range("C5").Value, True Extensions.Add "pptx", True Extensions.Add "ppt", True Extensions.Add "pptm", True For Each mySubFolder In myFolder.SubFolders For Each myFile In mySubFolder.Files ' i = Range("D4").Value If Extensions.Exists(FSO.GetExtensionName(myFile)) Then Cells(8 + i, 3).Value = myFile.Name Cells(8 + i, 4).Value = myFile.Path i = i + 1 Range("D4").Value = i 'storing number of entrys found 'Exit For End If Next Recurse = Recurse(mySubFolder.Path) Next End Function
'This Function creates a folder with the name "A1" if it does not exist already
Function PathExist(ByVal vPfadName As String) As Boolean scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value On Error GoTo ErrorPathExist ChDir (vPfadName) PathExist = True Exit Function ErrorPathExist: MkDir scutPath End Function
'Main Function that clears table and uses the found entries to get create shortcuts. Unfortunately the author is not integrated when doing it this way. The author is necessary to filter through hundreds of results.
Sub TestR() Range("B8:C999999") = "" Range("D4").Value = 0 Call Recurse(Application.ActiveWorkbook.Path) i = 1 scutPath = Application.ActiveWorkbook.Path & "\" & Range("A1").Value Call PathExist(scutPath) For i = 1 To 200 '(last line) Set oWSH = CreateObject("WScript.Shell") Set oShortcut = oWSH.CreateShortCut(scutPath & "\" & Cells(7 + i, 3).Value & ".lnk") With oShortcut .TargetPath = Cells(7 + i, 4).Value .Save End With Set oWSH = Nothing Next i MsgBox "Done" End Sub