Word VBA - Várias Funções

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

André Luiz Bernardes