[Resolvido]Mover Arquivos atraves do Access

Boa noite, Hary

Crie um formulário
Coloque uma caixa de listagem (nomeie-a de ListaFicheiros)
- tipo de origem de linha: lista de valores
- selecções múltiplas: simples

Coloque um botão de comando (nomeie-o de CmdMover)

cole num módulo:
Sub ActualizaLista()
Dim objFS, objPasta, objFicheiro
Set objFS = CreateObject("Scripting.FileSystemObject")
Set objPasta = objFS.GetFolder("C:\Users\User\Pictures\FotosDetentos")
ListaFicheiros.RowSource = ""
For Each objFicheiro In objPasta.Files
ListaFicheiros.AddItem objFicheiro.Name
Next
End Sub

código ao abrir do formaulário:
Private Sub Form_Open(Cancel As Integer)
Call ActualizaLista
End Sub

código para botão clique:
Private Sub CmdMover_Click()
On Error GoTo MostraErro

'Move Arquivos de uma pasta para Outra
Dim fso, Item
Dim strOrigem As String, strDestino As String

If ListaFicheiros.ItemsSelected.Count = 0 Then
MsgBox "Não tem nenhum ficheiro seleccionado."
Exit Sub
End If
strOrigem = "C:\Users\User\Pictures\FotosDetentos"
LePasta: strDestino = BrowseFolderPastaInicial("Escolha uma pasta para guardar o ficheiro", "C:\Syspen\Digita\Temp\")
If strDestino = "" Then
If MsgBox("Deve escolher uma pasta válida, ou cancelar a operação.", vbOKCancel) = vbYes Then
GoTo LePasta
Else
Exit Sub
End If
End If
Set fso = CreateObject("Scripting.FileSystemObject")
'Se é invalida a pasta de Origem ou Destino
If Not fso.FolderExists(strOrigem) Then
MsgBox strOrigem & " Caminho invalido para a pasta de origem.", vbInformation, "Erro"
ElseIf Not fso.FolderExists(strDestino) Then
MsgBox strDestino & " Caminho invalido para a pasta de destino", vbInformation, "Erro"
'Se não há arquivos a serem movidos
Else
For Each Item In ListaFicheiros.ItemsSelected
fso.MoveFile (strOrigem & "\" & ListaFicheiros.Column(0, Item)), strDestino
Next
Call ActualizaLista
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If
Exit Sub
MostraErro:
MsgBox err.Number & vbCr & err.Description
If err.Number = 53 Then MsgBox "Arquivos de Digital não encontrados..."
End Sub

Cumprimentos,

Boa noite alexande, cumprimentando pela pronta ajuda, tenho a informar que:

Fiz como orientou, mas ao abrir o novo form da erro na linha:
ListaFicheiros.RowSource = "" (O objeto é obrigatorio)
No for tem a a caixa de listagem com esse nome..
mas da esse erro...


Tenho no form de cadastro (onde cadastro o detendo) o botao mover que executa aquele codigo anterior, que funciona so nao escolhe os arquivos...

Pelo que entendi eu terei que criar um novo form e abri-lo com o botao do form cadastro e nesse novo form o código que me passou.. é isso?

Obrigado..

Boa noite, Hary

Fiz-lhe um pequeno exemplo. Veja no meus esnips
Cumprimentos,

Cumprimentando e lhe pedido escusas pela insistencia....

Baixei o seu modelo e funcionou em partes... abriu a origem, deu a escolha do ficheiro...

mas não moveu...

Possivelmente o erro esta acontecendo nessa linha:

Else
For Each Item In ListaFicheiros.ItemsSelected
fso.MoveFile (strOrigem & "\" & ListaFicheiros.Column(0, Item)), strDestino


Essa era a linha anterior que movia todos...
Else
fso.MoveFile (strOrigem & "\*.*"), strDestino

agora nesse novo codido do cmdmover.. nao esta movendo...


Se puder me ajudar ficarei grato, estou realmente necessitando disto..

Origado

Bom dia, Hary

Não referi, mas o código move apenas os ficheiros seleccionados na lista. Se não tiver seleccionado nenhum, não move.
Parece-me que, por vezes, o endereço de destino não é reconhecido por faltar a última barra invertida. Alterei o código:
1 - Para mover os seleccionados da lista
Private Sub CmdMover_Click()
On Error GoTo MostraErro

'Move Arquivos de uma pasta para Outra
Dim fso, Item
Dim strOrigem As String, strDestino As String

If ListaFicheiros.ItemsSelected.Count = 0 Then
MsgBox "Não tem nenhum ficheiro seleccionado."
Exit Sub
End If
strOrigem = "C:\Users\User\Pictures\FotosDetentos"
LePasta: strDestino = BrowseFolderPastaInicial("Escolha uma pasta para guardar o ficheiro", "C:\Syspen\Digita\Temp\")
If strDestino = "" Then
If MsgBox("Deve escolher uma pasta válida, ou cancelar a operação.", vbOKCancel) = vbYes Then
GoTo LePasta
Else
Exit Sub
End If
End If
Set fso = CreateObject("Scripting.FileSystemObject")
'Se é invalida a pasta de Origem ou Destino
If Not fso.FolderExists(strOrigem) Then
MsgBox strOrigem & " Caminho invalido para a pasta de origem.", vbInformation, "Erro"
ElseIf Not fso.FolderExists(strDestino) Then
MsgBox strDestino & " Caminho invalido para a pasta de destino", vbInformation, "Erro"
'Se não há arquivos a serem movidos
Else
If Right(strDestino, 1) <> "\" Then strDestino = strDestino & "\"
For Each Item In ListaFicheiros.ItemsSelected
fso.MoveFile (strOrigem & "\" & ListaFicheiros.Column(0, Item)), strDestino
Next
Call ActualizaLista
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If
Exit Sub
MostraErro:
MsgBox err.Number & vbCr & err.Description
End Sub

2 - Para mover todos os ficheiros
Private Sub CmdMover_Click()
On Error GoTo MostraErro

'Move Arquivos de uma pasta para Outra
Dim fso, Item
Dim strOrigem As String, strDestino As String

If ListaFicheiros.ItemsSelected.Count = 0 Then
MsgBox "Não tem nenhum ficheiro seleccionado."
Exit Sub
End If
strOrigem = "C:\Users\User\Pictures\FotosDetentos"
LePasta: strDestino = BrowseFolderPastaInicial("Escolha uma pasta para guardar o ficheiro", "C:\Syspen\Digita\Temp\")
If strDestino = "" Then
If MsgBox("Deve escolher uma pasta válida, ou cancelar a operação.", vbOKCancel) = vbYes Then
GoTo LePasta
Else
Exit Sub
End If
End If
Set fso = CreateObject("Scripting.FileSystemObject")
'Se é invalida a pasta de Origem ou Destino
If Not fso.FolderExists(strOrigem) Then
MsgBox strOrigem & " Caminho invalido para a pasta de origem.", vbInformation, "Erro"
ElseIf Not fso.FolderExists(strDestino) Then
MsgBox strDestino & " Caminho invalido para a pasta de destino", vbInformation, "Erro"
'Se não há arquivos a serem movidos
Else
If Right(strDestino, 1) <> "\" Then strDestino = strDestino & "\"

For I = 0 To ListaFicheiros.ListCount - 1
fso.MoveFile (strOrigem & "\" & ListaFicheiros.Column(0, I)), strDestino
Next
Call ActualizaLista
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If
Exit Sub
MostraErro:
MsgBox err.Number & vbCr & err.Description
End Sub


Apesar de algumas adaptações, deve funcionar.
Cumprimentos,

Muito Muito Obrigado alexandre, a questão foi resolvida...

Em tempo: um amigo que estava tentando me ajudar tambem, fez um outro tipo...

O que ele faz: Esolhe o arquivo na Origem, cria a pasta de destino com a ID do detento, renomeia a foto do detento na origem, e ja a move para a pasta do mesmo...

Tentei enviar por aqui para deixea disponivel a todos do forum.. mas Infelizmente nao consigo mandar nada por aqui...\

Acaso alguem interesse, envie-me uma mensagem que envio o modelo..
Ficou muito bom...

e nesse modelo tambem tem uma rotina de alteração da Letra da Unidade (C:) caso tenha que se alterar a letra na tabela do cmainho da foto caso use em rede...

Deixo meus sinceros agradecimentos ao Forum e me coloco a disposição para ajudar no que for preciso...

Fiquem com Deus..
Harysohn