sFolder = Range("A1").Value2
I added that and modified the icon selection, as I did not have those ICO's, and set the iconlabel as the filename. Obviously, A1 should not have a trailing backslash. If A1 as a value, you may need to add a check to see if that folder does exists. e.g.
MsgBox Len(Dir(sFolder, vbDirectory))<>0
Option Explicit
Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long
'http://www.vbaexpress.com/forum/showthread.php?53380-Extract-files-as-a-object-into-excel-from-folder-path\
Sub Add9FilesWithIcons()
Dim iconToUse As String, fullFileName As String, FNExtension As String
Dim shp As OLEObject, sFolder As String, aFN() As String, i As Integer
Dim j As Integer
sFolder = Range("A1").Value2
If sFolder = "" Then _
sFolder = Get_Folder("X:\Test", "Import Folder")
If sFolder = "" Then Exit Sub 'User Cancelled
aFN() = Filter(Split(CreateObject("Wscript.Shell").Exec("cmd /c dir x:\test\*.* /b").StdOut.ReadAll, vbCrLf), _
ThisWorkbook.Name, False, vbTextCompare)
ReDim Preserve aFN(0 To UBound(aFN) - 1) 'Trim trailing vbcrlf
'MsgBox "Folder: " & sFolder & vbLf & vbLf & "Files: " & vbLf _
& Join(aFN, vbCrLf), vbInformation, UBound(aFN) + 1 & " Files"
'Set number of files to embed, maximum of 9
j = UBound(aFN) + 1
If j > 9 Then j = 9
For i = 0 To j - 1
fullFileName = sFolder & "\" & aFN(i)
FNExtension = Right(fullFileName, Len(fullFileName) - _
InStrRev(fullFileName, "."))
'select icon based on filename extension
Select Case UCase(FNExtension)
Case Is = "TXT"
iconToUse = "C:\Windows\system32\packager.dll"
Case Is = "XLS", "XLSM", "XLSX"
iconToUse = "C:\Windows\Installer\{91140000-0011-0000-0000-0000000FF1CE}\xlicons.exe"
Case Is = "PDF"
iconToUse = "C:\Windows\Installer\{AC76BA86-1033-F400-7761-000000000004}\_PDFFile.ico"
Case Else
'this is a generic icon
iconToUse = "C:\Windows\system32\packager.dll"
End Select
'Set shp = ActiveSheet.OLEObjects.Add(Filename:=fullFileName, Link:= _
False, DisplayAsIcon:=True, IconFileName:= _
iconToUse, IconIndex:=0, IconLabel:=fullFileName)
Set shp = ActiveSheet.OLEObjects.Add(Filename:=fullFileName, Link:= _
False, DisplayAsIcon:=True, IconFileName:= _
ExePath(fullFileName), IconIndex:=0, IconLabel:=aFN(i))
shp.Top = Range("B20").Offset(, i).Top + 1
shp.Left = Range("B20").Offset(, i).Left + 1
Next i
End Sub
Function Get_Folder(Optional FolderPath As String, _
Optional HeaderMsg As String) As String
With Application.FileDialog(msoFileDialogFolderPicker)
If FolderPath = "" Then
.InitialFileName = Application.DefaultFilePath
Else
.InitialFileName = FolderPath
End If
.Title = HeaderMsg
If .Show = -1 Then
Get_Folder = .SelectedItems(1)
Else
Get_Folder = ""
End If
End With
End Function
Sub Test_ExePath()
MsgBox ExePath(ThisWorkbook.FullName)
End Sub
Function ExePath(lpFile As String) As String
Dim lpDirectory As String, sExePath As String, rc As Long
lpDirectory = "\"
sExePath = Space(255)
rc = FindExecutable(lpFile, lpDirectory, sExePath)
ExePath = sExePath
End Function
Sub DeleteAllShapes()
Dim s As Shape, ws As Worksheet
For Each ws In Worksheets
For Each s In ws.Shapes
s.Delete
Next s
Next ws
End Sub
Reply With Quote
