Word VBA - Diversas Funções.

Que tal algumas funções para utilizar o VBA no MS Word?

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, ByVal strMacroButton 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

    On Error Resume Next

    Application.CommandBars("Menu Bar").Controls("docsonline").Delete

    On Error GoTo 0

    Let vCtrlCount = CommandBars("MenuBar").Controls.Count

    Let vCtrlCount = vCtrlCount + 1

    With CommandBars("MenuBar").Controls

        .Add(Type:=msoControlPopup, Before:=vCtrlCount).Caption ="&docsonline"

    End With

    'Make the new menu start the group

    With CommandBars("MenuBar").Controls("docsonline")

        Let .BeginGroup = True

    End With

    Set ctlControl = CommandBars("MenuBar").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("MenuBar").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

Sub DeletaTachado()

    Dim oTexto As Word.Range

    Set oTexto = ActiveDocument.Range

    With oTexto.Find

        .ClearFormatting

        .Replacement.ClearFormatting

        Let .Text = "*"

        Let .MatchWildcards = True

        Let .Font.StrikeThrough = True

        Let .Replacement.Text = ""

        .Execute Replace:=wdReplaceAll

    End With

End Sub

Funções CHR (Character):
Aqui estão alguns dos mais comuns código ASCII utilizados:

Chr(9) = tabChr(11) = manual line break (shift-enter)
Chr(12) = manual page breakChr(13) = vbCrLf (return)Chr(14) = column break
Chr(30) = non-breaking hyphenChr(31) = optional hyphenChr(32) = spaceChr(34) = quotation mark
Chr(160) = nonbreaking space

Sub Table_To_Text() 

'October 5, 2008 by Derrick Duehren 

'Converts the current table to regular text. 

'Handy when forwarding emails with annoying nested tables of content. 

On Error GoTo TheEnd 

Selection.Rows.ConvertToText Separator:=wdSeparateByParagraphs, _ 

NestedTables:=True 

Selection.Find.ClearFormatting 

Selection.Find.Replacement.ClearFormatting 

With Selection.Find 

Let .Text = "^l" 

Let .Replacement.Text = "^p" 

Let .Forward = True 

Let .Wrap = wdFindAsk 

Let .Format = False 

End With 

Selection.Find.Execute Replace:=wdReplaceAll 

Selection.HomeKey Unit:=wdLine 

TheEnd: 

End Sub

Esta função formata o texto selecionado com a fonte Veranda, com o tamanho 10, e como azul escuro. Pode utilizar dentro do Outlook, para pré formatar algum texto que for colado nele.

Sub FormatVeranda() 

' Macro created August 18, 2008 by Derrick Duehren 

' Formats the selected text as Veranda font, size 10, dark blue.

On Error GoTo EH 

Selection.Font.Name = "Verdana" 

Selection.Font.Size = 10 

Selection.Font.Color = wdColorDarkBlue 

Exit Sub 

EH: 

If Err.Number = 4605 Then 

msgbox "You need to switch to HTML format for this email." 

End If 

End Sub

Sub NoIndent_Bullet_List() 

'Turn the selected text into a bullet list with no indent. 

With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1) 

Let .NumberFormat = ChrW(61623) 

Let .TrailingCharacter = wdTrailingTab 

Let .NumberStyle = wdListNumberStyleBullet 

Let .NumberPosition = InchesToPoints(0.25) 

Let .Alignment = wdListLevelAlignLeft 

Let .TextPosition = InchesToPoints(0.5) 

Let .TabPosition = InchesToPoints(0.5) 

Let .ResetOnHigher = 0 

Let .StartAt = 1 

With .Font 

Let .Bold = wdUndefined 

Let .Italic = wdUndefined 

Let .StrikeThrough = wdUndefined 

Let .Subscript = wdUndefined 

Let .Superscript = wdUndefined 

Let .Shadow = wdUndefined 

Let .Outline = wdUndefined 

Let .Emboss = wdUndefined 

Let .Engrave = wdUndefined 

Let .AllCaps = wdUndefined 

Let .Hidden = wdUndefined 

Let .Underline = wdUndefined 

Let .Color = wdUndefined 

Let .Size = wdUndefined 

Let .Animation = wdUndefined 

Let .DoubleStrikeThrough = wdUndefined 

Let .Name = "Symbol" 

End With 

Let .LinkedStyle = "" 

End With 

Let ListGalleries(wdBulletGallery).ListTemplates(1).Name = "" 

Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _ 

wdBulletGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:= _ 

wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior 

With Selection.ParagraphFormat 

Let .LeftIndent = InchesToPoints(0.25) 

Let .RightIndent = InchesToPoints(0) 

Let .SpaceBefore = 0 

Let .SpaceBeforeAuto = False 

Let .SpaceAfter = 0 

Let .SpaceAfterAuto = False 

Let .LineSpacingRule = wdLineSpaceSingle 

Let .Alignment = wdAlignParagraphLeft 

Let .WidowControl = True 

Let .KeepWithNext = False 

Let .KeepTogether = False 

Let .PageBreakBefore = False 

Let .NoLineNumber = False 

Let .Hyphenation = True 

Let .FirstLineIndent = InchesToPoints(-0.25) 

Let .OutlineLevel = wdOutlineLevelBodyText 

Let .CharacterUnitLeftIndent = 0 

Let .CharacterUnitRightIndent = 0 

Let .CharacterUnitFirstLineIndent = 0 

Let .LineUnitBefore = 0 

Let .LineUnitAfter = 0 

End With 

Selection.ParagraphFormat.TabStops.ClearAll 

Let ActiveDocument.DefaultTabStop = InchesToPoints(0.5) 

Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.25), _ 

Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 

End Sub 

Numbered List with No Indent

This Word function turns the selected text into a numbered list with no indent. 

Sub NoIndent_Numbers() 

' Macro recorded May 6, 2009 by Derrick Duehren 

'Turn the selected text into a bullet list with no indent. 

With ListGalleries(wdNumberGallery).ListTemplates(1).ListLevels(1) 

.NumberFormat = "%1." 

.TrailingCharacter = wdTrailingTab 

.NumberStyle = wdListNumberStyleArabic 

.NumberPosition = InchesToPoints(0.25) 

.Alignment = wdListLevelAlignLeft 

.TextPosition = InchesToPoints(0.5) 

.TabPosition = InchesToPoints(0.5) 

.ResetOnHigher = 0 

.StartAt = 1 

With .Font 

.Bold = wdUndefined 

.Italic = wdUndefined 

.StrikeThrough = wdUndefined 

.Subscript = wdUndefined 

.Superscript = wdUndefined 

.Shadow = wdUndefined 

.Outline = wdUndefined 

.Emboss = wdUndefined 

.Engrave = wdUndefined 

.AllCaps = wdUndefined 

.Hidden = wdUndefined 

.Underline = wdUndefined 

.Color = wdUndefined 

.Size = wdUndefined 

.Animation = wdUndefined 

.DoubleStrikeThrough = wdUndefined 

.Name = "" 

End With 

.LinkedStyle = "" 

End With 

ListGalleries(wdNumberGallery).ListTemplates(1).Name = "" 

Selection.Range.ListFormat.ApplyListTemplate ListTemplate:=ListGalleries( _ 

wdNumberGallery).ListTemplates(1), ContinuePreviousList:=True, ApplyTo:= _ 

wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior 

With Selection.ParagraphFormat 

.LeftIndent = InchesToPoints(0.25) 

.RightIndent = InchesToPoints(0) 

.SpaceBefore = 0 

.SpaceBeforeAuto = False 

.SpaceAfter = 0 

.SpaceAfterAuto = False 

.LineSpacingRule = wdLineSpaceSingle 

.Alignment = wdAlignParagraphLeft 

.WidowControl = True 

.KeepWithNext = False 

.KeepTogether = False 

.PageBreakBefore = False 

.NoLineNumber = False 

.Hyphenation = True 

.FirstLineIndent = InchesToPoints(-0.25) 

.OutlineLevel = wdOutlineLevelBodyText 

.CharacterUnitLeftIndent = 0 

.CharacterUnitRightIndent = 0 

.CharacterUnitFirstLineIndent = 0 

.LineUnitBefore = 0 

.LineUnitAfter = 0 

End With 

Selection.ParagraphFormat.TabStops.ClearAll 

ActiveDocument.DefaultTabStop = InchesToPoints(0.5) 

Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.25), _ 

Alignment:=wdAlignTabLeft, Leader:=wdTabLeaderSpaces 

Selection.ParagraphFormat.TabStops.Add Position:=InchesToPoints(0.5), _ 

Alignment:=wdAlignTabList 

End Sub

Reference: Derrick Duehren 

Tags: Bernardes, Windows, MS, Office, Word, FilePathExists, ShowProgress, MakeTable, AddMacroButton, TruncPathForLabel, sOpenBrowser, BuildCustomMenu, NewCatalog, SetTable, CheckTableContents, DoTheseThings, DeletaTachado, Table_To_Text, FormatVeranda, NoIndent_Bullet_List, NoIndent_Numbers

André Luiz Bernardes

A&A® - Work smart, not hard.

VBA Blogs

  

bernardes@.com