Word VBA - Várias Funções - Parte 01.

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

André Luiz Bernardes A&A - WORK, DON´T PLAY! http://al-bernardes.sites.uol.com.br/ bernardess@gmail.com