locked
Senha de Proteção - Macro para definição em Massa RRS feed

  • Pergunta

  • Bom dia!

     

    Estou com um problema, preciso definir uma senha de proteção para vário arquivos do Excel, mas ao invés de fazer um a um, gostaria de saber se alguém pode me ajudar a criar uma macro para isso!!!

     

    Será que tem como??

     

    Obrigado!

    terça-feira, 31 de julho de 2007 11:47

Respostas

  • SOLUÇÂO DO PROBLEMA!!!

     

    Com base neste artigo: http://www.everythingaccess.com/tutorials.asp?ID=List-files-recursively

     

    Mudei o código um pouco, e fiz assim:

     

    Code Snippet

    Sub Teste()
       
        Dim Arquivos As New Collection
       
        Call ListFiles("c:\Local dos Arquivos\", "*.xls", , Arquivos)
       
        Dim i As Integer
       
        For i = 1 To Arquivos.Count
            Workbooks.Open Filename:=Arquivos.Item(i)
            ActiveWorkbook.SaveAs Filename:=Arquivos.Item(i), FileFormat _
            :=xlNormal, Password:="SUA SENHA", WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
            ActiveWindow.Close
        Next
       
    End Sub

     

    Public Function ListFiles(strPath As String, Optional strFileSpec As String, _
        Optional bIncludeSubfolders As Boolean, Optional lst As Collection)
    On Error GoTo Err_Handler
        'Purpose: List the files in the path.
        'Arguments: strPath = the path to search.
        '         strFileSpec = "*.*" unless you specify differently.
        '         bIncludeSubfolders: If True, returns results from subdirectories of strPath as well.
        '         lst: if you pass in a list box, items are added to it. If not, files are listed to immediate window.
        '             The list box must have its Row Source Type property set to Value List.
        'Method:    FilDir() adds items to a collection, calling itself recursively for subfolders.
        Dim colDirList As New Collection
        Dim varItem As Variant
       
        Call FillDir(colDirList, strPath, strFileSpec, bIncludeSubfolders)
       
        'Add the files to a list box if one was passed in. Otherwise list to the Immediate Window.
        If lst Is Nothing Then
            For Each varItem In colDirList
                Debug.Print varItem
            Next
        Else
            For Each varItem In colDirList
            lst.Add varItem
            Next
        End If

    Exit_Handler:
        Exit Function

    Err_Handler:
        MsgBox "Error " & Err.Number & ": " & Err.Description
        Resume Exit_Handler
    End Function

    Private Function FillDir(colDirList As Collection, ByVal strFolder As String, strFileSpec As String, _
        bIncludeSubfolders As Boolean)
        'Build up a list of files, and then add add to this list, any additional folders
        Dim strTemp As String
        Dim colFolders As New Collection
        Dim vFolderName As Variant

        'Add the files to the folder.
        strFolder = TrailingSlash(strFolder)
        strTemp = Dir(strFolder & strFileSpec)
        Do While strTemp <> vbNullString
            colDirList.Add strFolder & strTemp
            strTemp = Dir
        Loop

        If bIncludeSubfolders Then
            'Build collection of additional subfolders.
            strTemp = Dir(strFolder, vbDirectory)
            Do While strTemp <> vbNullString
                If (strTemp <> ".") And (strTemp <> "..") Then
                    If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0& Then
                        colFolders.Add strTemp
                    End If
                End If
                strTemp = Dir
            Loop
            'Call function recursively for each subfolder.
            For Each vFolderName In colFolders
                Call FillDir(colDirList, strFolder & TrailingSlash(vFolderName), strFileSpec, True)
            Next vFolderName
        End If
    End Function

    Public Function TrailingSlash(varIn As Variant) As String
        If Len(varIn) > 0& Then
            If Right(varIn, 1&) = "\" Then
                TrailingSlash = varIn
            Else
                TrailingSlash = varIn & "\"
            End If
        End If
    End Function

    Sub Macro1()
    '
    ' Macro1 Macro
    ' Macro gravada em 31/07/2007 por Informática
    '

    '
      
    End Sub

     

     

    Eh isso ae...

     

    Abraço!


    terça-feira, 31 de julho de 2007 14:39