Is This Possible?

[euanuk]

Hi,

I would like to create a library of files (that I have stored on my PC) in excel with a tick box assigned to each.

The user of the worksheet would select which files they wished to open using the tick boxes. Once they had selected which files they wished to view they could press a command button and the files would open (files would be in PDF format).

Is a function like this possible in Excel?

Thanks

Euan

 

[JackDanIce]

I don't think what you want is possible with a function, however, is do-able via a macro.

 

[Weaver]

Yes, you could do this, but you'd most likely need either a lot of manual work (copying/pasting/typing) or you could use vb code to:

1. collect a list of filenames in a given folder andinsert them into the sheet, alongside a tickbox
2. create a button that when clicked activates code that checks the checkboxes one at a time and decides whether the file should be opened or not.

I could come up with the code, in fact I've already posted something that could be used for the checkboxes today, but it might take a while. I'll take another look at it later if this hasn't been answered.

 

[euanuk]

Thanks for the help, much appreciated.


Euan

 

[tweedle]

I wrote something to collect files and hyperlink them, may be a start for you.
too much code/setup to post really; here's the file:

https://docs.google.com/leaf?id=0B6...JhYTMtMTZiMDE1NTUxNWM0&hl=en&authkey=CM-M6q0J

 

[euanuk]

Hi Tweedle,

Thanks for the link but I can't seem to get it to open. Could be this PC I'm using.

Would a code like this be difficult to develop. I am a complete VB novice and have only really used Excel for it's basic functions in the past.

Any pointers would be much appreciated.

Thanks

Euan

 

[tweedle]

Yes, there's a good bit to it.
We can give it a shot.

Once you get all this set up, Click on Setup button and it will advise how to enter paths. Then click your ListFiles button.


Setting up the sheets:
Needs 3 sheets named:
-FileList: Holds the process output (potentially gets deleted and recreated)
-FilePaths: Holds a list of filepaths (potentially gets deleted and recreated)
-Main: Holds the buttons
Needs 1 module.

The Setup sheet gets two activeX commandbuttons:

1 named cmdSetup
1 named cmdListFiles

Private Sub cmdSetup_Click()
    Call Setup
End Sub

and

Private Sub cmdListFiles_Click()
    Call ListFilesInFolder
End Sub

'Code goes in a Module
Sub Setup()
'Goes through a setup routine to clear and make sure we have the sheets necessary
'Called from Button 
On Error Resume Next
Dim msg$
Dim retval As Variant
'check for worksheet and delete if exists
ActiveWorkbook.Worksheets("FilePaths").Select True
If Err.Number = 0 Then
    retval = MsgBox("Do you want to Delete the existing sheet?", vbYesNo, "Existing Sheet Found!")
    If retval = vbYes Then
        ActiveWorkbook.Worksheets("FilePaths").Delete
    Else    'vbNo
        Exit Sub
    End If
End If
Debug.Print Err.Number, Err.Description
'add worksheet
Dim wksht As Worksheet
Set wksht = ActiveWorkbook.Worksheets.Add
With wksht
    .Name = "FilePaths"
End With
Range("A1").Select
msg$ = "A sheet called FilePaths has been created." & vbCrLf
msg$ = msg$ & "Start in A1 and list the paths to inventory." & vbCrLf
msg$ = msg$ & "they can look like this:" & vbCrLf
msg$ = msg$ & "C:\Users\owner\Documents\ " & vbCrLf & "for mapped drives" & vbCrLf
msg$ = msg$ & "OR Like this for shared server paths:" & vbCrLf
msg$ = msg$ & "[URL="file://\\servername\Shared\Files\Documents\"]\\servername\Shared\Files\Documents\[/URL]" & vbCrLf
retval = MsgBox(msg$, vbOKOnly, "Set Up")
msg$ = "CAUTION." & vbCrLf
msg$ = msg$ & "HIGH LEVEL PATHS SUCH AS 'C:\' MAY RESULT IN MANY MANY MANY FILES LISTED" & vbCrLf
retval = MsgBox(msg$, vbExclamation, "Set Up")
End Sub

Sub ListFilesInFolder()
'Called from button
'Essentially setting up the sheet
Err = 0
On Error Resume Next
Worksheets("FilePaths").Select
Dim FilePathArray() As String
nCol = 1
nRow = 1
ReDim FilePathArray(0)
While Not IsEmpty(Worksheets("FilePaths").Cells(nRow, nCol))
        ReDim Preserve FilePathArray(UBound(FilePathArray()) + 1)
        ArrayEl = UBound(FilePathArray)
        If Right(Trim(Cells(nRow, 1).Value), 1) <> "\" Then
            Var$ = Trim(Cells(nRow, 1).Value) & "\"
        Else
            Var$ = Trim(Cells(nRow, 1).Value)
        End If
        FilePathArray(ArrayEl) = Var$
    nRow = nRow + 1
Wend
ActiveWorkbook.Worksheets("FileList").Delete
'add worksheet
Dim wksht As Worksheet
Set wksht = ActiveWorkbook.Worksheets.Add
With wksht
    .Name = "FileList"
End With
' add headers
With Range("A1")
.Formula = "Folder contents:"
.Font.Bold = True
.Font.Size = 12
End With
Range("A3").Formula = "File LongName:"
Range("B3").Formula = "File Size:"
Range("C3").Formula = "File Type:"
Range("D3").Formula = "Date Created:"
Range("E3").Formula = "Date Last Accessed:"
Range("F3").Formula = "Date Last Modified:"
Range("G3").Formula = "Attributes:"
Range("H3").Formula = "Short File Name:"
Range("I3").Formula = "File Path:"
Range("J3").Formula = "File Name:"
Range("A3:J3").Font.Bold = True
For x = 0 To UBound(FilePathArray())
    Debug.Print x, FilePathArray(x)
    If FilePathArray(x) <> "" Then
        ListFilesInFolderPart2 FilePathArray(x), True
    End If
Next x
'SAMPLE USE: ListFilesInFolderPart2 "C:\Users\owner\Documents\Forum Sampling\", True
' The True says to look in sub folders also
' Set to False if you do not want that

Range("A1").Select  'Go to beginning of the sheet
Call Splash
End Sub

Sub ListFilesInFolderPart2(SourceFolderName As String, IncludeSubfolders As Boolean)
' lists information about the files in SourceFolder
' example: ListFilesInFolder "C:\FolderName\", True
On Err GoTo ERR_PROCESS:
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder, SubFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim r As Long
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
r = Range("A65536").End(xlUp).Row + 1
For Each FileItem In SourceFolder.Files
' display file properties
Cells(r, 1).Formula = FileItem.Path ' & FileItem.Name
Cells(r, 2).Formula = FileItem.Size
Cells(r, 3).Formula = FileItem.Type
Cells(r, 4).Formula = FileItem.DateCreated
Cells(r, 5).Formula = FileItem.DateLastAccessed
Cells(r, 6).Formula = FileItem.DateLastModified
Cells(r, 7).Formula = FileItem.Attributes
Cells(r, 8).Formula = FileItem.ShortPath ' & FileItem.ShortName
Cells(r, 9).Formula = FileItem.Path
Cells(r, 10).Formula = FileItem.Name
'Cells(r, 11).Formula = PictureDimensions(FileItem.Path)
'Cells(r, 11).Formula = GetDetailsOf(FileItem.Path, 26)
Cells(r, 1).Activate
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    Cells(r, 1).Value, TextToDisplay:= _
    Cells(r, 1).Value
    
Cells(r, 9).Activate
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    Cells(r, 1).Value, TextToDisplay:= _
    Cells(r, 9).Value
    
Cells(r, 10).Activate
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:= _
    Cells(r, 1).Value, TextToDisplay:= _
    Cells(r, 10).Value

r = r + 1   ' next row number
Next FileItem
If IncludeSubfolders Then
    For Each SubFolder In SourceFolder.SubFolders
        ListFilesInFolderPart2 SubFolder.Path, True
        DoEvents
    Next SubFolder
End If
        With Range("C1")
            .Formula = "COMPLETED:" & Date & " " & Time()
            .Font.Bold = True
            .Font.Size = 12
        End With
Range("B1").Select
Columns("A:j").AutoFit
Exit Sub

ExitGracefully:
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
    If Err <> 0 Then
        With Range("C1")
            .Formula = "OOOPS: " & Err.Description
            .Font.Bold = True
            .Font.Size = 12
        End With
    End If
ActiveWorkbook.Saved = True
Exit Sub
ERR_PROCESS:
Debug.Print Err.Number, Err.Description
Resume ExitGracefully
End Sub

Supporting Functions:

Function GetDetailsOf(strfilepath As String, attr As Integer)
    Dim objShell  As Shell
    Dim objFolder As Folder
    Set objShell = New Shell
    Set objFolder = objShell.Namespace(strfilepath)
    
    If (Not objFolder Is Nothing) Then
        Dim objFolderItem As FolderItem
        Set objFolderItem = objFolder.ParseName(strfilepath)
   
        If (Not objFolderItem Is Nothing) Then
            Dim szItem As String
            attrVal = objFolder.GetDetailsOf(objFolderItem, attr)
            GetDetailsOf = attrVal
        Else
            GetDetailsOf = vbNull
        End If
        
        Set objFolderItem = Nothing
    End If
    
    Set objFolder = Nothing
    Set objShell = Nothing
End Function

Function PictureDimensions(filePath As String) As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Shell.Application")
If Not FSO.FileExists(filePath) Then
PictureDimensions = ""
End If
strParent = FSO.GetParentFolderName(filePath)
strArgFileName = FSO.GetFileName(filePath)
Set objFolder = objShell.Namespace(strParent)
Debug.Print objFolder.GetDetailsOf(strArgFileName, 0)
For Each strFileName In objFolder.Items
   If objFolder.GetDetailsOf(strArgFileName, 0) = strArgFileName Then
   PictureDimensions = objFolder.GetDetailsOf(strArgFileName, 26)
   retval = objFolder.GetDetailsOf(strArgFileName, 31)
   retval1 = objFolder.GetDetailsOf(strArgFileName, 26)
   End If
Next
retval = objFolder.GetDetailsOf(strArgFileName, 31).Value
For xy = 0 To 180
    Debug.Print xy, objFolder.GetDetailsOf(strArgFileName, xy)
Next xy
Set FSO = Nothing
Set objShell = Nothing
End Function

Function Splash()
msg$ = "--Removed--"
'MsgBox msg$, vbOKOnly, "DONE!"
End Function

 

[cedricthecat]

You could try this, which at least gives the directory listing

(I'm not taking the credit for this - can't remember where I got it from though! Change Const ListDir to point to your folder)

Sub DirList()
  Const ListDir = "C:\Documents and Settings\USERNAME\YOUR FOLDER\"
  If Not Dir(ListDir & "*.xls") = "" Then
    Flist = Dir(ListDir & "*.xls")
    R = 1
    Do Until Flist = ""
      Cells(R, 1).Value = ListDir & Flist
      R = R + 1
      Flist = Dir
    Loop
  End If
  Cells.Replace What:="C:\Documents and Settings\dhyde\Desktop\Working Folder\" _
        , Replacement:="", LookAt:=xlPart, SearchOrder:=xlByRows, MatchCase:= _
        False, SearchFormat:=False, ReplaceFormat:=False
        Columns("A:A").EntireColumn.AutoFit
End Sub

 

[tweedle]

FYI: This version also requires a reference to the Miscrosoft Scripting Runtime
Alt + F11 to VBE, Menu Tools/References
check Microsoft Scripting Runtime.