Views

Histats

Vitrine

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

ReferenceDerrick 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 Brazil®

✔ VBA Brazil®
brazilsalesforceeffectiveness@gmail.com
Related Posts Plugin for WordPress, Blogger...
diHITT - Notícias