Decidi cooperar com algumas funções úteis sobre código VBA para o MS Word...
Divirtam-se!
Option Explicit
Public BoolCancel As Boolean
Public BoolSelected As Boolean
Public BoolDoSpecialActions As Boolean
Public lngTableRows As Long
Public BoolTableMade As Boolean
Public objFSO As Object
Public lngCounter As Long
Public arrFileTypes()
Public strPickedPath As String
Private Const SW_SHOW = 5 ' Displays Window in its current size ' and position
Private Const SW_SHOWNORMAL = 1 ' Restores Window if Minimized or ' Maximized
Private Declare
Function ShellExecute Lib "shell32.dll" Alias _
"ShellExecuteA" (ByVal hwnd As Long, ByVal lpOperation As _
String, ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Private Declare
Function FindExecutable Lib "shell32.dll" Alias _
"FindExecutableA" (ByVal lpFile As String, ByVal lpDirectory As _
String, ByVal lpResult As String) As Long
Sub GetStarted(Optional ByVal strFolderPath)
Let BoolDoSpecialActions = False
Let BoolTableMade = False
Let lngCounter = 0
If BoolCancel Then Exit Sub
If IsMissing(strFolderPath) Then strFolderPath = "C:\"
If Right(strFolderPath, 1) <> "\" Then strFolderPath = strFolderPath &
"\"
If Selection.ExtendMode Then Selection.ExtendMode = False
If Application.ScreenUpdating Then Application.ScreenUpdating = False
If frmOptions.chkDoSpecialActions.Value = True Then
Let BoolDoSpecialActions = True
End If
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
Google Talk: 
Skype: inanyplace
MSN: 
