Public ifile
Option Base 1
Public afiles()
Sub GetFileList()
Dim IsOpen As Integer
Dim TheFile As String
Dim Ffp As String
Dim CDir As String
Let CDir = CurDir
Dim FileDir As String
Dim Ans As Variant
Dim DataArray(150, 4) As Variant
Dim TabToRefresh
Let TabToRefresh = ActiveSheet.Name
Beep
Let Ans = MsgBox(Prompt:="Are you sure you wish to repopulate this file?", Title:="FLIR Systems, Inc.", Buttons:=vbOKCancel)
If Ans <> 1 Then Exit Sub
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Cursor = xlWait
With Application
.Calculation = xlManual
.MaxChange = 0.001
End With
ifile = 0
'clear out the last population of data
For X = 2 To 100
For Y = 1 To 4
DataArray(X, Y) = Cells(X, Y).Value
Cells(X, Y).Value = Empty
Next
Next
'the value of "thepath" should be a SharePoint site in this format:
'\\globalstd@SSL\DavWWWRoot\team\icxcorp\acctg\GL Closing\Detection\201609 Sep\Account Recons\
Let FileDir = Range("thepath")
ListFilesInDirectory FileDir, 0
'this places the file names in column B of the current sheet
For IsOpen = 1 To ifile
Cells(1 + IsOpen, 2).Value = afiles(IsOpen)
Next
Call DoHyper
Sheets(TabToRefresh).Select
Range("B2:E" & ifile + 1).Select
ActiveWorkbook.Worksheets(TabToRefresh).Sort.SortFields.Clear
ActiveWorkbook.Worksheets(TabToRefresh).Sort.SortFields.Add Key:=Range("B2:B" & ifile + 1) _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets(TabToRefresh).Sort
.SetRange Range("B1:E" & ifile + 1)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Application.EnableEvents = True
Application.Cursor = xlDefault
With Application
.Calculation = xlAutomatic
.MaxChange = 0.001
End With
End Sub
Sub DoHyper()
Dim X As Long
Dim TheFileOnly As String
Let X = 2
Do While True
If Cells(X, 2).Value = Empty Then Exit Do
Let Filename = Cells(X, 2).Value
'Cells(X, 2).FormulaR1C1 = "=HYPERLINK(" & Filename & ")"
Cells(X, 2).Select
Let TheFileOnly = FileFromPath(Filename)
ActiveCell.Hyperlinks.Add ActiveCell, Filename, TextToDisplay:=TheFileOnly
X = X + 1
Loop
End Sub
Private Sub ListFilesInDirectory(Directory As String, EraseIt As Integer)
'This is called by the list all files function above.
Dim X As Integer, Y As Integer
Dim StartRow As Integer
Dim aDirs() As String, iDir As Integer, stFile As String
Dim SubName As String
Dim Goback As Integer
Dim Counter As Integer
Let SubName = "ListInDir"
On Error GoTo handleCancelListInDir
' use Dir function to find files and directories in Directory
' look for directories and build a separate array of them
' note that Dir returns files as well as directories when vbDirectory
' specified
If EraseIt = 1 Then
Application.GoTo Reference:="PathToRename"
X = ActiveCell.Row + 1
Y = ActiveCell.Column + 1
Cells(X, Y).Select
X = ActiveCell.Row
End If
iDir = 0
stFile = Directory & Dir(Directory & "*.*", vbDirectory)
Do While stFile <> Directory
If Right(stFile, 2) = "\." Or Right(stFile, 3) = "\.." Then
' do nothing - GetAttr doesn't like these directories
ElseIf GetAttr(stFile) = vbDirectory Then
' add to local array of directories
iDir = iDir + 1
ReDim Preserve aDirs(iDir)
aDirs(iDir) = stFile
Else
ifile = ifile + 1
ReDim Preserve afiles(ifile)
afiles(ifile) = stFile
End If
stFile = Directory & Dir()
Loop
If iDir > 0 Then
For iDir = 1 To UBound(aDirs)
ListFilesInDirectory aDirs(iDir) & Application.PathSeparator, 0
Next iDir
End If
If EraseIt = 1 Then
StartRow = X
For Y = 1 To ifile
Cells(X, 1).Value = afiles(Y)
X = X + 1
Next
Cells(StartRow, 1).Select
End If
Exit Sub
handleCancelListInDir:
Let Counter = Counter + 1
If Counter > 50 Then
If Err = 18 Then
Let Goback = MsgBox(Prompt:="You interrupted the program by hitting the Escape key. The system will return to the point where you caused this intervention. Thank you. (Note, if you wish to stop the program click Cancel instead of OK)", Title:="FLIR Systems User Intervention by " & UsrID, Buttons:=vbYesNoCancel + vbCritical)
Else
Let Goback = MsgBox(Prompt:="BE SURE TO REFRESH THE B:\ DRIVE!!!! In Sub " & SubName & ", there is an Error (" & Err.Number & ") of " & Err.Description & ". The system will return to the point where this error was caused. Thank you.", Title:="FLIR User System Error", Buttons:=vbOKCancel + vbCritical)
End If
DetailsCntr = DetailsCntr + 1
Goback = 1
If Goback = 1 Then 'Selected OK
Resume
ElseIf Goback = 2 Then 'Selected Cancel
Exit Sub
ElseIf Goback = 6 Then 'Selected Yes
Resume
ElseIf Goback = 7 Then 'Selected NO
Resume Next
End If
Else
Resume
End If
End Sub
Public Function FileFromPath(ByVal strFullPath As String, Optional bExtensionOff As Boolean = False) As String
'this function parses file names from a full path and file and extension text.
Dim FPL As Long 'len of full path
Dim PLS As Long 'position of last slash
Dim pd As Long 'position of dot before exension
Dim strFile As String
On Error GoTo ERROROUT
FPL = Len(strFullPath)
PLS = InStrRev(strFullPath, "\", , vbBinaryCompare)
strFile = Right$(strFullPath, FPL - PLS)
If bExtensionOff = False Then
FileFromPath = strFile
Else
pd = InStr(1, strFile, ".", vbBinaryCompare)
FileFromPath = Left$(strFile, pd - 1)
End If
Exit Function
ERROROUT:
On Error GoTo 0
FileFromPath = ""
End Function
(
