VBA Tips - Substituindo caracteres nos nomes de arquivos num diretório - Replace Characters in the Filenames of a Directory

Termo de Responsabilidade 

A funcionalidade que observaremos no código abaixo substituirá os caracteres (strings) em todos os nomes de arquivos presentes no diretório fornecido.

Útil em inúmeras situações, quais?

- Quando desejar criar relatórios dentro de pastas.

- Quando precisar gravar dados em pastas criadas anteriormente e precise ajustar o nome do período.

- Quando desejar gravar relatórios dentro de pastas com os respectivos nomes dos agrupamentos.

- Etc...

Use o código abaixo e se divirta:

Function Repl_Char_FName (ByVal Path As String, ByVal OldChr As String, ByVal NewChr As String)

    Dim FileName As String

    'Input Validation

    'Trailing backslash (\) is a must

    If Right(Path, 1) <> "\" Then Path = Path & "\"

    

    'Directory must exist and should not be empty.

    If Len(Dir(Path)) = 0 Then

        Let Repl_Char_FName  = "No files found."

        Exit Function

    'Old character and New character must not be empty or null strings.

    ElseIf Trim(OldChr) = "" And OldChr <> " " Then

        Let Repl_Char_FName  = "Invalid Old Character."

        Exit Function

    ElseIf Trim(NewChr) = "" And NewChr <> " " Then

        Let Repl_Char_FName  = "Invalid New Character."

        Exit Function

    End If

    

    Let FileName = Dir(Path & "*.*") 'Use *.xl* para Excel e *.doc para arquivos Word

    Do While FileName <> ""    

        Name Path & FileName As Path & Replace (FileName, OldChr, NewChr)

        Let FileName = Dir

    Loop

    Let Repl_Char_FName = "Ok"

End Function

Teste as funcionalidades:

Sub Samp_Use()

    Dim lResult As String

    

    lResult = Replace_Filename_Character("C:\Bernardes\Test", " ", "_")

    Debug.Print lResult 'Returns Ok

    

    lResult = Replace_Filename_Character("C:\Bernardes\Test", " ", "_")

    Debug.Print lResult 'Returns Ok though no spaces in filenames now

    

    lResult = Replace_Filename_Character("C:\Bernardes\Test\", "", "_")

    Debug.Print lResult 'Returns 'Invalid Old Character'

    

    lResult = Replace_Filename_Character("C:\Bernardes\Test01", " ", "_")

    Debug.Print lResult 'Returns 'No files found' as invalid directory provided.

End Sub

Tags: VBA, tips, string, substituir, replace

VBA Powerpoint - Localize e substitua códigos no MS PowerPoint - Global Find And Replace routine in PowerPoint

Vamos dar uma olhada em como fazer uso do método Replace do objeto TextRange no MS PowerPoint para criar uma funcionalidade de localizar e substituir a nível global, substituindo o texto em todas as apresentações abertas.

Nota: O modelo de objeto do PowerPoint 2007 quebra a linha - Do While Not oTmpRng. Se estiver usando mudança PPT 2007, a linha será Do While oTmpRng.Text <> "".

Além disso, observe que para 2007 PPT, você deve verificar a propriedade ContainedType para determinar o conteúdo dentro da forma de espaço reservado e processá-lo em conformidade.

Sub GlobalFindAndReplace()

Dim oPres As Presentation

Dim oSld As Slide

Dim oShp As Shape

Dim FindWhat As String

Dim ReplaceWith As String

FindWhat = "Like"

ReplaceWith = "Not Like"

For Each oPres In Application.Presentations

     For Each oSld In oPres.Slides

        For Each oShp In oSld.Shapes

            Call ReplaceText(oShp, FindWhat, ReplaceWith)

        Next oShp

    Next oSld

Next oPres

End Sub

Sub ReplaceText (oShp As Object, FindString As String, ReplaceString As String)

Dim oTxtRng As TextRange

Dim oTmpRng As TextRange

Dim I As Integer

Dim iRows As Integer

Dim iCols As Integer

Dim oShpTmp As Shape

' Always include the 'On error resume next' statememt below when you are working with text range object.

' I know of at least one PowerPoint bug where it will error out - when an image has been dragged/pasted

' into a text box. In such a case, both HasTextFrame and HasText properties will return TRUE but PowerPoint

' will throw an error when you try to retrieve the text.

On Error Resume Next

Select Case oShp.Type

Case 19 'msoTable

    For iRows = 1 To oShp.Table.Rows.Count

        For icol = 1 To oShp.Table.Rows(iRows).Cells.Count

            Set oTxtRng = oShp.Table.Rows(iRows).Cells(iCol).Shape.TextFrame.TextRange

            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _

Replacewhat:=ReplaceString, WholeWords:=True)

Do While Not oTmpRng Is Nothing

Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _

Replacewhat:=ReplaceString, _

After:=oTmpRng.Start + oTmpRng.Length, _

WholeWords:=True)

Loop

        Next

    Next

Case msoGroup 'Groups may contain shapes with text, so look within it

    For I = 1 To oShp.GroupItems.Count

        Call ReplaceText(oShp.GroupItems(I), FindString, ReplaceString)

    Next I

Case 21 ' msoDiagram

    For I = 1 To oShp.Diagram.Nodes.Count

        Call ReplaceText(oShp.Diagram.Nodes(I).TextShape, FindString,     ReplaceString)

    Next I

Case Else

    If oShp.HasTextFrame Then

        If oShp.TextFrame.HasText Then

            Set oTxtRng = oShp.TextFrame.TextRange

            Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _

                Replacewhat:=ReplaceString, WholeWords:=True)

            Do While Not oTmpRng Is Nothing

                Set oTmpRng = oTxtRng.Replace(FindWhat:=FindString, _

                            Replacewhat:=ReplaceString, _

                            After:=oTmpRng.Start + oTmpRng.Length, _

                            WholeWords:=True)

            Loop

       End If

    End If

End Select

End Sub

Referência: Shyam Pillai, Joe Stern

Tags: Powerpoint, Slide, UDF, TextRange, Replace, substitute

André Luiz Bernardes

A&A® - Work smart, not hard.

VBA Blogs

  

  

bernardes@.com