GetFiles (strFolderPath) If frmOptions.chkRecurse.Value <> False Then GetFolders (strFolderPath) End If With Application If Not .ScreenUpdating Then .ScreenUpdating = True .ScreenRefresh End With If Not frmOptions.optNoTable Then If Not BoolTableMade Then MakeTable End If If Not frmOptions.optNoTable Then With ActiveDocument.Tables(1).Rows(1) Let Selection.Font.Size = 9
With .Shading Let .Texture = wdTextureNone Let .ForegroundPatternColor = wdColorAutomatic Let .BackgroundPatternColor = wdColorTurquoise End With
Let Selection.Font.Size = 9 End With End If Set objFSO = Nothing If Not frmOptions.optNoTable Then SetTable CheckTableContents End If frmProgress.Hide End Sub Sub GetFolders(strCurrFolder) Dim objFolders As Object Dim FoldSubs Dim strFolder If BoolCancel Then Exit Sub Set objFSO = CreateObject("scripting.FileSystemObject") Set objFolders = objFSO.GetFolder(strCurrFolder) Set FoldSubs = objFolders.SubFolders For Each strFolder In FoldSubs Application.ScreenRefresh GetFiles strFolder If frmOptions.chkRecurse.Value <> False Then GetFolders strFolder End If If Err <> 0 Then Err.Clear Let Err.Number = 0 End If Next End Sub Sub GetFiles(strFolderName) Dim lngFileCounter As Long Dim objFolders As Object Dim FoldFiles Dim lngArrSize As Long Dim i As Long Dim intLength As Integer Dim intDotPos As Integer Dim strMatch As String Dim strTrimmed As String Dim strInsert As String Dim strFile If BoolCancel Then Exit Sub Set objFSO = CreateObject("scripting.FileSystemObject") Set objFolders = objFSO.GetFolder(strFolderName) Set FoldFiles = objFolders.Files Let lngArrSize = UBound(arrFileTypes) Let lngFileCounter = 0 For Each strFile In FoldFiles If BoolCancel Then Exit Sub If frmOptions.chkFullPath = True Then Let strInsert = strFile.Name Else Let strInsert = strFile End If
Let lngFileCounter = lngFileCounter + 1
ShowProgress lngFileCounter, CLng(FoldFiles.Count), objFolders
For i = 0 To lngArrSize 'Following Lines commented for File Type bug 'results in types of .2.doc, etc 'intDotPos = InStr(strFile.Name, ".") 'intLength = Len(strFile.Name) 'strMatch = LCase(Right(strFile.Name, intLength - intDotPos)) 'Improved strMatch routine Let strMatch = FileType(strFile.Name) Let strTrimmed = LCase(Trim(arrFileTypes(i)))
If strMatch = strTrimmed Then MakeEntry strMatch, strFile, strInsert
'This is where any special stuff can be done! If BoolDoSpecialActions = True Then DoTheseThings (strFile) End If
If Err <> 0 Then Err.Clear Err.Number = 0 End If Let lngCounter = lngCounter + 1 ElseIf arrFileTypes(0) = "All" Then MakeEntry strMatch, strFile, strInsert End If Next i Next strFile DoEvents End Sub
Function FileType(ByVal strName As String) As String Dim arrType As Variant Dim Bound As Long Let arrType = Split(strName, ".") Let Bound = UBound(arrType) Let FileType = arrType(Bound) End Function
Sub MakeEntry(ByVal strExt As String, ByVal strFileName As String, ByVal strShownText) Dim myrange As Range If frmOptions.optNoTable Then ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:=strFileName, TextToDisplay:=strShownText Selection.InsertAfter vbNewLine & vbNewLine Selection.EndKey Unit:=wdStory, Extend:=False Else If Not BoolTableMade Then MakeTable
With Selection ActiveDocument.Tables(1).Rows.Add Let lngTableRows = lngTableRows + 1 With ActiveDocument.Tables(1).Rows(lngTableRows).Cells(2).Range .Delete Set myrange = ActiveDocument.Tables(1).Rows(lngTableRows).Cells(2).Range ActiveDocument.Hyperlinks.Add Anchor:=myrange, Address:=strFileName, TextToDisplay:=strShownText End With With ActiveDocument.Tables(1).Rows(lngTableRows).Cells(3).Range .Delete .InsertAfter strExt End With
End With DoEvents End If With ActiveDocument Let .SpellingChecked = True .UndoClear End With End Sub
Function GetSearchPath() Let GetSearchPath = BrowseFolder.BrowseFolder$("Browse Search Folder...") End Function Sub GetControlType() Dim ctrl As Control Dim lngCount As Long Dim ctrlName As String ReDim arrFileTypes(0) Let lngCount = 0
For Each ctrl In frmOptions.framOptions.Controls If ctrl.Name <> "chkShow" And InStr(1, ctrl.Name, "chk") Then Let ctrlName = ctrl.Name
If ctrl.Value = True Then Let arrFileTypes(lngCount) = Right(ctrlName, Len(ctrlName) - 3) ReDim Preserve arrFileTypes(lngCount + 1) End If
End If Next ctrl End Sub
Function FilePathExists(strPickedPath) As Boolean Set objFSO = CreateObject("scripting.FileSystemObject") If objFSO.FolderExists(strPickedPath) Then Let FilePathExists = True Else Let FilePathExists = False End If End Sub Sub ShowProgress(ByVal snglFileCounter, ByVal snglCount, ByVal strFolderPath As String) Dim snglDecimal As Single Dim snglWidth As Single Dim strLabelText As String If BoolCancel Then Exit Sub Let snglDecimal = snglFileCounter / snglCount Let snglWidth = snglDecimal * 280 Let strLabelText = TruncPathForLabel(strFolderPath) Let frmProgress.lblPercent.Caption = "Folder scan is " & FormatPercent(snglDecimal) & " complete." Let frmProgress.lblStatus.Caption = snglCount & " files in " & strLabelText Let frmProgress.lblProgress.Width = snglWidth frmProgress.Repaint End Sub Sub MakeTable() Dim MyTableRange Dim Active If BoolCancel Then Exit Sub Set Active = ActiveDocument If ActiveDocument.Tables.Count = 0 Then Set MyTableRange = Active.Tables.Add(Range:=Active.Range(Start:=0, End:=0), NumRows:=1, NumColumns:=3) AddMacroButton 1, "MACROBUTTON TableSortAToZ Description " AddMacroButton 2, "MACROBUTTON TableSortAToZ File Path/Name " AddMacroButton 3, "MACROBUTTON TableSortAToZ File Type " With ActiveDocument.Tables(1) .Columns(1).SetWidth ColumnWidth:=InchesToPoints(2.3), RulerStyle:=wdAdjustProportional .Columns(2).SetWidth ColumnWidth:=InchesToPoints(4.5), RulerStyle:=wdAdjustProportional .Columns(3).SetWidth ColumnWidth:=InchesToPoints(0.7), RulerStyle:=wdAdjustProportional End With Let lngTableRows = 1 End If Let BoolTableMade = True End Sub Sub AddMacroButton(ByVal lngCellNumber As Long, ByValstrMacroButton As String) Dim CellRange As Range If BoolCancel Then Exit Sub Set CellRange =ActiveDocument.Tables(1).Rows(1).Cells(lngCellNumber).Range CellRange.Select CellRange.Delete Selection.Fields.Add Range:=CellRange, Type:=wdFieldEmpty,text:=strMacroButton, preserveformatting:=False End Sub Sub pMacroClickOptions() If BoolCancel Then Exit Sub If frmOptions.chkSort.Value = True Then With Options Let .ButtonFieldClicks = 1 End With Else With Options Let .ButtonFieldClicks = 2 End With End If End Sub Function TruncPathForLabel(strText)Dim intLen As Integer Dim intMarkLeft As Integer Dim intMarkRight As Integer Dim strLeft As String Dim strConj As String Dim strRight As String Dim strLabelText As String If BoolCancel Then Exit Function Let intLen = Len(strText) If intLen > 60 Then Let intMarkLeft = InStr(15, strText, "\") Let intMarkRight = InStrRev(strText, "\", -1) Let strLeft = Left(strText, intMarkLeft) Let strConj = "..." Let strRight = "\" & Right(strText, intLen - intMarkRight) Let strLabelText = strLeft & strConj & strRight Let TruncPathForLabel = strLabelText Else Let TruncPathForLabel = strText End If End Sub Sub sOpenBrowser(FileName) Dim Dummy As String Dim RetVal As Long Dim hwnd Let RetVal = ShellExecute(hwnd, "open", FileName, "", Dummy, SW_SHOWNORMAL) End Sub Sub BuildCustomMenu() Dim vCtrlCount As Long Dim ctlControl ''' Always attempt to delete any previously existing ''' custom toolbars when you first start up. ''' Rebuild them rather than trying to reuse them. On Error Resume Next Application.CommandBars("Menu Bar").Controls("docsonline").Delete On Error GoTo 0 ''' Create the custom command bar. Let vCtrlCount = CommandBars("Menu Bar").Controls.Count Let vCtrlCount = vCtrlCount + 1 With CommandBars("Menu Bar").Controls .Add(Type:=msoControlPopup, Before:=vCtrlCount).Caption = "&docsonline" End With 'Make the new menu start the group With CommandBars("Menu Bar").Controls("docsonline") Let .BeginGroup = True End With ''' Add the buttons. Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&New Catalog" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "NewCatalog" Set ctlControl = CommandBars("Menu Bar").Controls("docsonline").Controls.Add(msoControlButton) Let ctlControl.Caption = "&About docsonline" Let ctlControl.Style = msoButtonCaption ''' Display only the caption text." Let ctlControl.OnAction = "Aboutdocsonline" Let ActiveDocument.Saved = True End Sub Sub NewCatalog() Application.Documents.Add 'Template:=Templates(1).FullName, Visible:=True frmOptions.Show End Sub Sub SetTable() ActiveDocument.Tables(1).Select Let Selection.Font.Size = 9 ActiveDocument.Tables(1).AutoFitBehavior _ wdAutoFitWindow Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=False Let ActiveDocument.SpellingChecked = True End Sub Sub CheckTableContents() If ActiveDocument.Tables(1).Rows.Count = 1 Then ActiveDocument.Tables(1).Delete Selection.InsertAfter "There were no files or subfolders in the selected path." End If End Sub Sub DoTheseThings(strFile) Debug.Print strFile End Sub
