Boa tarde, tenho este código funcionável, no entanto queria-o dividir pelo menos em duas partes, ele corre as pastas de um caminho que lhe dou, e consoante os filtros ele insere certas pastas e ficheiros num zip.
Desde já muito obrigado, tenho de melhorar e dividir melhor as funções, pois esta pode ser dividida em duas ou três diferentes.
PS: Não liguem ao nome da função porque antes eu estava a pesquisar os ficheiros por extensão.
Public Sub GetExtension()
Dim objFSO, myFolder, mySubFolder, myFile, queue As Collection
Dim myExtension, strZip, licensa As String
Dim sngStart As Single
Dim data As String
Dim objShell, objZip, fso As Object
Set objFSO = CreateObject("Scripting.FileSystemObject") 'Create an instance of the FileSystemObject
Set queue = New Collection
queue.Add objFSO.GetFolder(Application.LicomdatPath) 'Get and define the folder object
Set myFolder = objFSO.GetFolder(Application.LicomdatPath)
Set mySubFolder = myFolder.SubFolders
'Zip file variables and creation
licensa = (Application.License.GetCustomerName) 'Company name
data = Date
Set objShell = CreateObject("Shell.Application")
strZip = "C:\hello\Backup_" & licensa & ".zip"
Set fso = CreateObject("Scripting.FileSystemObject")
Set objZip = fso.CreateTextFile(strZip)
objZip.WriteLine Chr(80) & Chr(75) & Chr(5) & Chr(6) & String(18, 0)
objZip.Close
Do While queue.Count > 0
Set myFolder = queue(queue.Count)
queue.Remove (queue.Count)
'loops through each file in the directory and prints their names and path
For Each mySubFolder In myFolder.SubFolders
If mySubFolder.Name Like "R*" Then
objShell.Namespace("" & strZip).CopyHere mySubFolder.Path
sngStart = Timer
Do While Timer < sngStart + 2
DoEvents
Loop
Else
End If
queue.Add mySubFolder
Next mySubFolder
For Each myFile In myFolder.Files
If myFile.Name Like "R*" Then
objShell.Namespace("" & strZip).CopyHere myFile.Path
sngStart = Timer
Do While Timer < sngStart + 2
DoEvents
Loop
Else
End If
Next myFile
Loop
MsgBox "ola"
End Sub
↧