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
André Luiz Bernardes
A&A - WORK, DON´T PLAY!
http://al-bernardes.sites.uol.com.br/
bernardess@gmail.com
Nenhum comentário:
Postar um comentário