[Resolvido]Mover Arquivos atraves do Access

Saudações a todos, estou usando um comando em access que move arquivos de uma pasta para outra atraves de um botao no for. access...isso eu já consigui, mas preciso que na hora que eu mova os arquivos ele me de a opção da escolha da pasta: Segue o modelo como estou fazendo:

Private Sub Mover_Arquivos_Click()

'Move Arquivos de uma pasta para Outra
Dim fso
Dim strOrigem As String, strDestino As String
strOrigem = "C:\Syspen\Digital\Michael"
strDestino = "C:\Syspen\Digital\teste"
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
'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 serme movidos
Else
fso.MoveFile (strOrigem & "\*.*"), strDestino
End If
If Err.Number = 53 Then MsgBox "Arquivos de Digital não encontrados..."

'Se os arquivos forem movidos com sucesso aviso
If fso.MoveFile(strOrigem & "\*.*") Then
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If

End Sub

As pastas ja estão criadas... so preciso que ele me de a opcao de em qual pasta eu vou mover os arquivos... tipo um msg box com o campo para adicionar caminho da pasta.. (no campo tem que ter o caminho inicial, bastando o usuario adicionar apenas a pasta, sem que precise redigitar o caminho completo toda vez que for mover os arquivos)

Preciso tambem que se caso na haja arquivos na pasta ele nao emita o aviso da linha

'Se os arquivos forem movidos com sucesso aviso
If fso.MoveFile(strOrigem & "\*.*") Then
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If


Se puderem me ajudar, ficarei imensamente Grato.

Boa noite, Hary

Utilize este código:


'Stephen Lebans has added functionality to open the browse folder at a specific place.

'************** Code Start **************
'This code was originally written by Terry Kreft.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
'Code courtesy of
'Terry Kreft

Private Type BROWSEINFO
hOwner As Long
pidlRoot As Long
pszDisplayName As String
lpszTitle As String
ulFlags As Long
lpfn As Long
lParam As Long
iImage As Long
End Type

Private Declare Function SHGetPathFromIDList Lib "shell32.dll" Alias _
"SHGetPathFromIDListA" (ByVal pidl As Long, _
ByVal pszPath As String) As Long

Private Declare Function SHBrowseForFolder Lib "shell32.dll" Alias _
"SHBrowseForFolderA" (lpBrowseInfo As BROWSEINFO) _
As Long

Private Const BIF_RETURNONLYFSDIRS = &H1

Public Function BrowseFolder(szDialogTitle As String) As String
Dim X As Long, bi As BROWSEINFO, dwIList As Long
Dim szPath As String, wPos As Integer

With bi
.hOwner = hWndAccessApp
.lpszTitle = szDialogTitle
.ulFlags = BIF_RETURNONLYFSDIRS
End With

dwIList = SHBrowseForFolder(bi)
szPath = Space$(512)
X = SHGetPathFromIDList(ByVal dwIList, ByVal szPath)

If X Then
wPos = InStr(szPath, Chr(0))
BrowseFolder = Left$(szPath, wPos - 1)
Else
BrowseFolder = vbNullString
End If
End Function
'*********** Code End *****************

Cumprimentos,

Novamente, Harry

Cole o código num módulo e guarde.

Para escolher a pasta de guarda, utilize o seguinte código (apenas adaptei o código que indicou):

Private Sub Mover_Arquivos_Click()

'Move Arquivos de uma pasta para Outra
Dim fso
Dim strOrigem As String, strDestino As String
strOrigem = "C:\Syspen\Digital\Michael"
LePasta: strDestino = BrowseFolder("Escolha uma pasta para guardar o ficheiro")
if strdestino="" then msgbox "Tem de escolher uma pasta válida." : goto LePasta
Set fso = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
'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 serme movidos
Else
fso.MoveFile (strOrigem & "\*.*"), strDestino
End If
If Err.Number = 53 Then MsgBox "Arquivos de Digital não encontrados..."

'Se os arquivos forem movidos com sucesso aviso
If fso.MoveFile(strOrigem & "\*.*") Then
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If

End Sub

Cumprimentos,

Boa noite alexandre...o procedimento deu certo... so quero aprimorar duas questões...

Observe essa parte do código:

no código sé é invalido a pasta de origem ou destino, ele retorna um MsgBox com o aviso.. E o Botão OK...
Clicando no OK ele volta para a esoclha da pasta.. ocorre que se porverntura desisitir nesse momento de mover os arquivos, não tem a opção de cancelar, pois ele fics alternando entre a msgbox e o browser.. Não dá pra canelar...

OUTRA COISA
Essa linha:

'Se os arquivos forem movidos com sucesso aviso
If fso.MoveFile(strOrigem & "\*.*") Then
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If


Eu gostaria que ela aparecesse apenas quando forem movido realmente os arquivos...
ela esta aparecendo mesmo se arquivos nao forem copiados...

Se puder me ajudar, desde ja peço desculpas pela inconveniencia..
Abraços
Harysohn


Há.. a janela esta aperecendo no diretorio raiz.. mostrando inicialmente o diretorio raiz, biblioteca etc..
tem como ele ja inicia no diretorio c:\Syspen\Digita\Temp ?

Boa noite, Harry

Grave estas funções num módulo:
Function BrowseFolderPastaInicial(Title As String, _
Optional InitialFolder As String = vbNullString, _
Optional InitialView As Office.MsoFileDialogView = _
msoFileDialogViewList) As String
'função adaptada por Alexandre Neves de função obtida na internet
Dim V As Variant
Dim InitFolder As String
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = Title
.InitialView = InitialView
If Len(InitialFolder) > 0 Then
If Dir(InitialFolder, vbDirectory) <> vbNullString Then
InitFolder = InitialFolder
If Right(InitFolder, 1) <> "\" Then
InitFolder = InitFolder & "\"
End If
.InitialFileName = InitFolder
End If
End If
.Show
On Error Resume Next
err.Clear
V = .SelectedItems(1)
If err.Number <> 0 Then
V = vbNullString
End If
End With
BrowseFolderPastaInicial = CStr(V)
End Function

Function ExisteFicheiro(Endereco As String, Optional TipoFicheiro As String) As Boolean
'www.esnips.com\web\alexandreneves
On Error Resume Next
Dim FSO, fl, Pasta, strNomeFicheiro As String

ExisteFicheiro = False
Set FSO = CreateObject("Scripting.FileSystemObject")
If InStr(1, Endereco, "*") > 0 Then
If ExistePasta(Endereco) Then
Set Pasta = FSO.GetFolder(EnderecoPasta(Endereco))
strNomeFicheiro = NomeFicheiro(Endereco)
For Each fl In Pasta.Files
If fl.Name Like strNomeFicheiro Then
ExisteFicheiro = True: GoTo FimDaFuncao
End If
Next
Else
ExisteFicheiro = False
End If
Else
ExisteFicheiro = False
If FSO.FileExists(Endereco) Then
ExisteFicheiro = True
Else
ExisteFicheiro = False
End If
End If
FimDaFuncao:
Set FSO = Nothing
End Function

Function ExistePasta(Endereco As String) As Boolean
'www.esnips.com\web\alexandreneves
Dim FSO
Dim EnderecoPasta As String, Cont As Integer

For Cont = Len(Endereco) To 1 Step -1
If Right(Mid(Endereco, 1, Cont), 1) = "\" Then
EnderecoPasta = Mid(Endereco, 1, Cont)
Exit For
End If
Next
Set FSO = CreateObject("Scripting.FileSystemObject")
If (FSO.FolderExists(EnderecoPasta)) Then
ExistePasta = True
Else
ExistePasta = False
End If
Set FSO = Nothing
End Function

Utilize este código:

Private Sub Mover_Arquivos_Click()

'Move Arquivos de uma pasta para Outra
Dim fso
Dim strOrigem As String, strDestino As String
strOrigem = "C:\Syspen\Digital\Michael"
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
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
fso.MoveFile (strOrigem & "\*.*"), strDestino
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If
If Err.Number = 53 Then MsgBox "Arquivos de Digital não encontrados..."

End Sub

Cumprimentos,

Bom dia Alexandre... eu coloquei a função que me enviou e a alteração para o (Mover arquivo)...

Ele abriu o folder conforme eu queria, mas agora não move os arquivos...
A funcao anterior movia, com essa alteracao ele nao move mais, ele abre o ficheiro na posição que eu quero mas nao move os arquivos do destino para a origem

Se puder me ajudar, fico grato

Com a permissão do Alexandre

Veja se assim serve o amigo

http://dl.dropbox.com/u/8157744/CopiarMover.zip

ele funcionou, mas o que quero realmente é mover...

Este programa que me enviou,copia os arquivos..

Outro detalhe.. a pasta de origem é fixa, eu nao quero a opcao de escolhé-la...

so iria escolher a pasta de destino, e que a janela ja abrisse no diretorio c:\syspen\digital...



Essa era a função que funcionava, ela apenas iniciava a janela na raiz...

'Move Arquivos de uma pasta para Outra
Dim fso
Dim strOrigem As String, strDestino As String
strOrigem = "C:\Syspen\Digital\Temp"
LePasta: strDestino = BrowseFolder("Escolha uma pasta para guardar o ficheiro")
if strdestino="" then msgbox "Tem de escolher uma pasta válida." : goto LePasta
Set fso = CreateObject("Scripting.FileSystemObject")

Essa foi a função modificada para o browserFolder iniciar em uma pasta especifica:

'Move Arquivos de uma pasta para Outra
Dim fso
Dim strOrigem As String, strDestino As String
strOrigem = "C:\Syspen\Digital\Temp"
LePasta: strDestino = BrowseFolderPastaInicial("Escolha uma pasta para guardar o ficheiro","C:\Syspen\Digital\")
if strdestino="" then
If MsgBox("Deve escolher uma pasta válida, ou cancelar a operação.", vbOKCancel) = vbYes Then

Há... e ele tem que mover todos os arquivos contidos na pasta sem dar opção de seleciona-los

SO que com essa alteracao ele abre na pasta Digital, mas não move os arquivos.


espero que tenha compreendido o que preciso..
Obrigado pela atenção..

Harysohn

Não experimentou convenientemente o exemplo enviado

1- Tem a opção de Mover

A Pasta de destino não é fixa...Clique no Botão Ir para escolher o destino

Veja tudo e experimente , por favor

Eu vi a opcao de mover...

so preciso agora que no botao "IR" ele ja iniciasse na pasta c:\syspena\Digital...

Creio que é nessa linha que inicia o diretorio
Execute
If Not .UserCancel Then
'User clicked Ok, so fill our control
'with the return value
Me.DestinationDir = .ReturnDir

gostaria queja executasse em: c:\syspen\digitak

Se puder ajudar...

Amigo

Coloque uma caixa de texto no form no qual vai chamar este e digite o camingo. A caixa pode ficar redimensionada para não ser visualizada

No form copiarMover na caixa Destination Dir na origem do controle

=([Formulários]![nomeformulário]![nomedacaixadetexto])

Assim:

Se a caixa que colocou com o caminho da Pasta de Destino tem o nome Pasta e o form tem o nome frm1, a digitação na Destination Dir seria:
=([Formulários]![frm1]![Pasta])

dessa maneira ele copia os arquivos para a pasta c:\syspen\digital...

Mas nao é bem assim que quero

eu quero escolher a pasta de destino...
mas quero que quando pressione " IR " o navegador inicie em c:\syspen\digital
e ele esta iniciando em c:

Obrigado

Amigo:

Não concordo, mas sé o que você quer:

Substitua o código neste botão:


Private Sub Imagem27_Click()
On Error Resume Next
Me.DestinationDir.Value = "C:\syspen\digital"
End Sub

Perdão, mas nao fucionou...
o botao nao abre o navegador...

quando clica no IR ele abre o navegador no diretorio computador..
para depois voce escoher as sub-pastas em c:

preciso que o navegador ja inicie em c:\syspen\digital

Obrigado

Amigão

Funciona a 100%, pois experimentei aqui com ficheiros diferentes. Baixe de novo o arquivo que eu já inseri o caminho que você quer. Como tem o mesmo nome do anterior, renomeie o existente para não se enganar.

Não precisa clicar no botão Ir, bast no executar.

Desculpe minha insistência amigo...

mas creio que não está entendendo....

Detro da pasta syspen existes varias pastas:

Pasta1
Pasta2
Pasta3 etc...

Eu tenho quie escolher a pasta....

soquero que o navegador que abre quando voce tecla a tecla ir... abra ja noi diretorio syspen, para que ai eu possa ai, escolher uma das pastas dentro da pasta syspen...


Do jeito que ta o seu exemplo ele apenas copia as arquivos para pasta digital...

Obrigado

Amigo

O exemplo cumpre perfeitamente, agora já não é só a pasta indicada, porque dentro dessa tem mais 3 pastas.

Então o sistema inicial de escolher a pasta de destino, era a melhor solução e a mais viável.

Se não tiver o exemplo inicial, diga-me que eu envio-lhe de novo

Certo amigo, o sisteminha que me enviu cumpre sim o que quero.... mas eu estou pensando no usuario leigo....
se eu usar esse que me enviou, primeiro o usuario tem que entrar em c:, depois em Syspen, depois em Digitai, para ai sim ter acesso as pastas.. o que quero e evitar esse passeio do usuario pelo diretorio Raiz... entao quando ele clicase na escolha da pasta de destino, ele ja abriria diretamente na pasta Syspen, para ai sim o usuario escolher as sub pastas..


Agradeço a paciencia e a sua ajuda...
Fique com Deus..
Se puder alterar isso Ficarei grati

Difícil amigo, pois só conheço p método que o Alexandre postou ou então este que me parece bem mais fácil e intuitivo além de permitir realizar o Copy ou o Move.

Por hora esse vai funcionar....
Mesmo assim muito obrigado pela ajuda...

Sempre ao dispor amigo.

Bom dia,

Amigo Vieira, não fiquei melindrado pela sua ajuda, afinal, o fórum é para partilharmos.
Eu apenas não tive tempo para, ontem, acompanhar mais de perto o assunto.

Agora, verifiquei o seguinte:
1 - Ontem às 11h32m, disse o Hary

A funcao anterior movia, com essa alteracao ele nao move mais, ele abre o ficheiro na posição que eu quero mas nao move os arquivos do destino para a origem

Provavelmente quereria dizer

A funcao anterior movia, com essa alteracao ele nao move mais, ele abre o ficheiro na posição que eu quero mas nao move os arquivos da origem para o destino

2 - Experimentei e funcionou com este código (faltava um End If)

'Move Arquivos de uma pasta para Outra
Dim fso
Dim strOrigem As String, strDestino As String
strOrigem = "D:\Zé Manel"
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
fso.MoveFile (strOrigem & "\*.*"), strDestino
MsgBox strOrigem & " ARQUIVOS MOVIDOS COM SUCESSO.", vbInformation, "Concluído"
End If
If err.Number = 53 Then MsgBox "Arquivos de Digital não encontrados..."

Espero ter respondido ao procurado.
Cumprimentos,

Obrigado Alexandre, a função correspondeu ao esperado.. funcionou perfeitamente como eu desejava...
Na oportunidade eu lhe agradeço pela atenção dispensada e coloco-me ao seu dispor ao que necessitar...
Obrigado.
Harysohn

Bom dia, Hary

Conforme resposta à msg privada, as dúvidas devem ser colocadas para que todos vejam e, assim, poder aprender ou ajudar. Devemos querer que os outros ajudem ou aprendam pois os outros somos nós.

Relativamente à dúvida colocada (para quem acompanha o assunto: poder escolher quais os ficheiros a mover), pretendo saber se a pasta é sempre a mesma, sem poder alterar mesmo para subpastas, ou o utilizador deve poder escolher outra pasta?
Cumprimentos,

Queira me desculpar com relação a mensagem privada, como disse, sou novo aqui e pensei que como essa mensagem já está com o status de resolvido, ëla não chegaria ate voce, por isso utilizei da mensagem privada...

Obrigado pela dica..
Harysohn

Com relação a questão: Ele vai Abrir no Diretorio:

strOrigem = "C:\Users\User\Pictures\FotosDetentos"

Não há sup-pasta, ele abre na pasta FotosDetentos para que eu escolha os arquivos a serem movidos..

Porque isso? na pasta fotos detentos terá varias fotos de diversos detentos, o comando mover vai mover apenas um detento especifico pra uma pasta com o seu nome no diretorio do comando:

lepasta: strDestino = BrowseFolderPastaInicial("Escolha uma pasta para guardar o ficheiro", "C:\Syspen\Imagens\"

Dentro do Diretorio imagens tem a pasta com o numero da ID do detento (criada quando se cadastra o mesmo)...

Quando se baixa os arquivos da maquina digital ela armazena no caminho "C:\Users\User\Pictures\FotosDetentos"
Ao cadastrar o detendo no BD, ele ja cria a pasta com a id do detendo no caminho: "C:\Syspen\Imagens\"

Entao no momento do cadastro ja move os arquivo da origem para o destino (pasta do detento) e adiciona as fotos no cadastro... As fotos ficam vinculadas al BD...

Espero ter sido claro è que tenha compreendido o porque da necessidade..

Obrigado mais uma vez Alexandre

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