Pequeno aplicativo para mover seus arquivos (de qualquer tipo) de um diretório "fonte" para um diretório de "destino".
Introdução
Software necessário para este aplicativo: Excel (todas as versões superiores a 97)
Referências - Editor VBE : "Microsoft Scripting Runtime"
Este procedimento utiliza uma biblioteca de objetos que, por padrão, não está incluída no editor do VBE. Devemos, então, adicionar uma referência a esta biblioteca:
- No VBE : (para acessá-lo, a partir de uma planilha da sua pasta do Excel, pressione simultaneamente as teclas ALT+F11)
- Menu : Ferramentas
- Escolher: Referências
- Marcar: "Microsoft Scripting Runtime"
Dois UserForms são necessários, aproveite o fato de ainda estar no VBE para criá-los:
Criação dos UserForms:
- No VBE:
- Menu : Inserção
- Escolher: UserForm
Controles a serem inseridos:
No l'UserForm1 :
- 4 Botões de Comando, (CommandButton1, CommandButton2, CommandButton3, CommandButton4)
- 2 Labels, encarregado de acolher os caminhos d acesso (Label1, Label2)
- 5 Labels, encarregado de acolher os nomes dos cabeçalhos das colunas da Listbox (Label3, Label4, Label5, Label6, Label7)
- 2 CheckBox (CheckBox1 (selecionar todos os arquivos), CheckBox2(Novo diretório))
- 1 ListBox (ListBox1)
No UserForm2 :
- 2 Botões de Comando, (CommandButton1, CommandButton2)
- 1 TextBox (TextBox1)
- 1 Label (facultativo)
UserForm1
Código do UserForm1
Opção Explicit
'---------------------------------------
'Procedimento de seleção de todos os arquivos da listbox
Private Sub CheckBox1_Click()
Dim i As Long
If CheckBox1.Value = True Then
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = False Then ListBox1.Selected(i) = True
Next i
Else
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then ListBox1.Selected(i) = False
Next i
End If
End Sub
'-------------------------------------
'Mostre o UserForm2 para criar um novo diretório
Private Sub CheckBox2_Click()
If CheckBox2.Value = True Then
UserForm2.Show
End If
End Sub
'--------------------------------------
'Escolha do diretório de destino
Private Sub CommandButton2_Click()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Escolher um diretório", &H1&)
If objFolder Is Nothing Then
MsgBox "Abandono do operador", vbCritical, "Cancelamento"
Else
Label2.Caption = objFolder.ParentFolder.ParseName(objFolder.Title).Path
End If
End Sub
'---------------------------------------
'Deslocamento dos arquivos selecionados
Private Sub CommandButton3_Click()
Dim i As Long
Dim source As String, destin As String, message As String
Dim oFSO As Scripting.FileSystemObject
Dim Rep As Integer
mensagem = "Tem certeza que quer mover os arquivos selecionados: " & vbLf & vbLf & Label1.Caption & vbLf & vbLf & "para: " & vbLf & vbLf & Label2.Caption
Rep = MsgBox(mensagem, vbYesNo + vbPergunta, "Confirmação")
If Rep = vbYes Then
Set oFSO = New Scripting.FileSystemObject
For i = 0 To ListBox1.ListCount - 1
If ListBox1.Selected(i) = True Then
source = Label1.Caption & "\" & ListBox1.List(i)
destin = Label2.Caption & "\" & ListBox1.List(i)
If oFSO.FileExists(source) Then
oFSO.MoveFile source, destin
End If
End If
Next i
ElementosDiretório Label1.Caption
MsgBox "Deslocamentos efetuados.", vbOKOnly + vbInformação, "Fim do processamento"
Else
MsgBox "Abandono do operador", vbCritical, "Cancelamento"
End If
End Sub
'--------------------------------------------
'Eliminação dos controles do UserForm1
Private Sub CommandButton4_Click()
ListBox1.Clear
Label1.Caption = ""
Label2.Caption = ""
CheckBox1.Value = False
CheckBox2.Value = False
End Sub
'------------------------------------------
'Inicialização da listbox
Private Sub UserForm_Initialize()
With ListBox1
.ColumnCount = 5
.ColumnWidths = "170;50;60;50;200"
.SetFocus 'inútil, apenas estético
End With
End Sub
'----------------------------------------
'escolha do diretório fonte
Private Sub CommandButton1_Click()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Escolher um diretório", &H1&)
If objFolder Is Nothing Then
MsgBox "Abandono do operador", vbCritical, "Cancelamento"
End
Else
ElementosDoDiretório objFolder.ParentFolder.ParseName(objFolder.Title).Path
End If
End Sub
'-----------------------------------------
'Preenchimento da listbox
Private Sub ElementosDoDiretório(Caminho As String)
Dim objShell As Object, strFileName As Object
Dim objFolder As Object
Dim NomFic As String, Passe As String
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.Namespace(CStr(Chemin))
Label1 = Caminho
ListBox1.Clear
For Each strFileName In objFolder.Items
If strFileName.isFolder = False Then
Passe = Caminho & "\" & strFileName & "*.*"
NomFic = Dir(Passe)
With ListBox1
.AddItem NomFic
.List(ListBox1.ListCount - 1, 1) = objFolder.GetDetailsOf(strFileName, 1)
.List(ListBox1.ListCount - 1, 2) = Format(objFolder.GetDetailsOf(strFileName, 4), "DD/MM/YYYY")
.List(ListBox1.ListCount - 1, 3) = Format(objFolder.GetDetailsOf(strFileName, 3), "DD/MM/YYYY")
.List(ListBox1.ListCount - 1, 4) = objFolder.GetDetailsOf(strFileName, 14)
End With
End If
Next strFileName
End Sub
UserForm2
Código do UserForm2
Opção Explicit
Dim CaminhoDiretórioParente As String
'-------------------------------------------
'Escolha do diretório parente, no qual será criado o nosso diretório
Private Sub CommandButton1_Click()
Dim objShell As Object, objFolder As Object
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Escolher um diretório", &H1&)
If objFolder Is Nothing Then
MsgBox "Abandono do operador", vbCritical, "Cancelamento"
Else
CaminhoDiretórioParente = objFolder.ParentFolder.ParseName(objFolder.Title).Path
End If
End Sub
'--------------------------------------------
'Criação do diretório
Private Sub CommandButton2_Click()
Dim oFSO As Scripting.FileSystemObject
Dim oFld As Folder
Dim CaminhoCompleto As String
If TextBox1 = "" Then Exit Sub
Set oFSO = New Scripting.FileSystemObject
CaminhoCompleto = CaminhoDiretórioParente & "\" & TextBox1
If oFSO.FolderExists(CaminhoCompleto) Then
MsgBox "Esta pasta já existe"
Exit Sub
Else
On Error Resume Next
Set oFld = oFSO.CreateFolder(CaminhoCompleto)
End If
UserForm1.Label2.Caption = CaminhoCompleto
UserForm1.CheckBox2.Value = False
Unload Me
End Sub
'----------------------------------------------------
'Impedir a entrada de caracteres proibidos ou não recomendados
Private Sub TextBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
If InStr("""!{['^]}/\*?<>|:", Chr(KeyAscii)) <> 0 Then
MsgBox "Caractere proibido ou não recomendado"
KeyAscii = 0
End If
End Sub
'-----------------------------------------------
'vidage du Textbox1
Private Sub UserForm_Initialize()
TextBox1 = ""
End Sub
Exemplo do uso
Em uma planilha do Excel, desenhe um botão de comando (no menu Exibir, barra de ferramentas: Caixa de ferramentas Controles).
No módulo da folha (para acessá-lo: Botão direito do mouse da planilha em questão/Visualizar o Código) copiar-colar este código:
Private Sub CommandButton1_Click()
'Inicializar
UserForm1.Show
End Sub
Download
Você pode baixar
A pasta de trabalho exemplo (emfrancês).
No entanto, se ele não estiver mais disponível no cijoint, favor me avisar, enviando-me um MP [communaute/profil-pijaku aqui, clique em "Escrever uma mensagem"]
Tradução feita por Lucia Maurity y Nouira
A ver igualmente
Comunidade de assistência e de conselho.
Artigo original publicado por
pijaku. Tradução feita por
pintuda.
