PDA

View Full Version : Extract files as a object into excel from folder path



rkulasekaran
08-05-2015, 03:01 AM
Hello,

I need a macro to extract files from the folder path directory, that is given as a input(folder path) in excel Cell A1. And a button placed in excel sheet, after clicking the button the files within the folder must be displayed as a object from cells B20 to J20. The first 9 files must only be read from the folder and placed in the cells.

I have written a macro for selecting a single file from the file browser and placed in excel.



Dim iconToUse As String
Dim fullFileName As String
Dim FNExtension As String


fullFileName = Application.GetOpenFilename("*.*, All Files", , , , False)


If fullFileName = "False" Then
Exit Sub ' user cancelled
End If


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


ActiveSheet.OLEObjects.Add(Filename:=fullFileName, Link:= _
False, DisplayAsIcon:=True, IconFileName:= _
iconToUse, IconIndex:=0, IconLabel:=fullFileName).Select


Any Help..Thanks in advance

Kenneth Hobs
08-05-2015, 07:13 AM
Change X:\Test to suit. When the folder picker dialog opens, delete the name in the input if you want the default folder. Otherwise, browse as usual and click OK.


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 = Get_Folder("X:\Test", "Import Folder")
If sFolder = "" Then Exit Sub 'User Cancelled
aFN() = Split(CreateObject("Wscript.Shell").Exec("cmd /c dir x:\test\*.* /b").StdOut.ReadAll, vbCrLf)
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)
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

rkulasekaran
08-05-2015, 08:24 AM
Thank you very much sir. I have change the folder and executed it. I was able to get the folder picker window after selecting the folder, i got the run time error as application defined or object defined error.kindly help me out.
Thanks in advance

Kenneth Hobs
08-05-2015, 08:39 AM
I suspect that you tried to import the current file. Did you select the same folder as in that workbook? It is not uncommon. Code can be added to check for that but I would normally just use Filter() to skip it.

rkulasekaran
08-05-2015, 09:00 AM
Thank you for you reply. I got it sir. So instead of file dialog picker the path directory can be specified in the A1 cell? how can make the button click to execute by taking the folder path as input instead of folder dialog picker .
the variable sFolder can be changed to A1 cell for input.
Thanks in advance.

Kenneth Hobs
08-05-2015, 09:13 AM
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

rkulasekaran
08-05-2015, 09:38 AM
Thankyou for your reply sir. I got a compile error as constants, user defined types are not allowed as public member of object modules from the blow code



Declare Function FindExecutable Lib "shell32.dll" Alias "FindExecutableA" _
(ByVal lpFile As String, ByVal lpDirectory As String, ByVal lpResult As String) As Long


So now i can remove the file dialog picker, so that the input can be directly taken from cell A1


sFolder = Range("A1").Value2
If sFolder = "" Then _
sFolder = Get_Folder("G:\desktop\tests", "Import Folder")
If sFolder = "" Then Exit Sub 'User Cancelled
aFN() = Filter(Split(CreateObject("Wscript.Shell").Exec("cmd /c dir G:\desktop\tests\*.* /b").StdOut.ReadAll, vbCrLf), _
ThisWorkbook.Name, False, vbTextCompare)
ReDim Preserve aFN(0 To UBound(aFN) - 1) 'Trim trailing vbcrlf


aFn() = sFolder.

Thanks in advance.

Kenneth Hobs
08-05-2015, 09:57 AM
API commands and Constants (Const) must be at the top of a Module after the Option line(s) but before and Sub()s or Function()s. See my post 6, last code block. You don't need that API though if you are just using your icon paths.

No, aFn() <> sFolder.

Notice how I filtered out the workbook's name with the macro using Filter(). I am not sure that Excel would even let you embed a file with the same base Excel filename if you wanted to. It is picky that way.

Kenneth Hobs
08-05-2015, 10:00 AM
Be sure to use this rather than a hardcoded string for the folder's path. I added sFolder for you.

aFN() = Filter(Split(CreateObject("Wscript.Shell").Exec("cmd /c dir " & """" & sFolder & """" & "\*.* /b").StdOut.ReadAll, vbCrLf), _
ThisWorkbook.Name, False, vbTextCompare)

rkulasekaran
08-06-2015, 08:26 AM
Thankyou very much sir. Got exactly what is required.

rkulasekaran
08-17-2015, 10:58 PM
Hi sir, In the above macro the user gives the input of the file directory in cell A3 and the contents are extracted. Now I need to extract the contents in the folder with only one file and the inputs(paths) are given from Cells U4 to U20 (9) paths after the clicking the button the files within the folder must be extracted as same from B20 to J20. for example if the second input path there is no file then the C20 must be blank and the next one must be filled. please do help me out.

Kenneth Hobs
09-14-2015, 09:29 AM
I am probably not seeing what you need right. I am not sure if the files are fully defined or just partial path/names.

Can you give an example of the value for say U4?