Tenho um processo simples onde um arquivo text chega por e-mail e eu devo salvá-lo em um determinado local dentro de uma pasta cuja o nome é uma data que esta dentro deste arquivo. Com isto em mente desenvolvi o código abaixo que faz o seguinte processo:
1) Através de uma regra de e-mail o Outlook verifica se o remetente da mensagem é o selecionado e caso sim, executa o código 2) O código salva o anexo em uma pasta chamada "temp" 3) O código lê a segundo linha do arquivo salvo onde esta localizada uma data 4) O Código renomeia esta pasta "temp" para a data lida no arquivo
O problema é que quando o código tenta renomear a pasta ele mostra a mensagem de erro de código 70 (Permissão negada).
É possível renomear uma pasta com arquivos dentro usando VBA (Outlook)?
Código:
Public Sub SalvarAnexo(Item)
Dim Atmt As Attachment
Dim FileName As String
Dim objFSO As Object
Dim objFile As Object
Dim strData As String
Dim caminhoTemp As String
Dim caminhoFinal As String
Dim caminhoFtp As String
Dim fdr
'MsgBox "Mensagem Recebida de " & Item.Sender & "!"
'caminhoTemp = "Z:\MIS\08.Bases\01.big data\01.PF\2015\temp"
'caminhoFinal = "Z:\MIS\08.Bases\01.big data\01.PF\2015\"
'caminhoFtp = "ftp://upgrademefiles.bigdatacorp.com.br/Arquivos%20TXT/PF/"
caminhoTemp = "C:\Users\caio.pirino\Documents\temp"
caminhoFinal = "C:\Users\caio.pirino\Documents\"
caminhoFtp = "C:\Users\caio.pirino\Documents\SalvaAuto\temp"
Call CriaDiretorio(caminhoTemp)
For Each Atmt In Item.Attachments
If Right$(Atmt.FileName, 3) = "TXT" Then
Set objFSO = CreateObject("Scripting.FileSystemObject")
FileName = caminhoTemp & "\" & Atmt.FileName
Atmt.SaveAsFile FileName
Set objFile = objFSO.OpenTextFile(FileName, 1)
strData = objFile.ReadLine
strData = objFile.ReadLine
strData = Left$(strData, 10)
strData = Replace(strData, "-", "")
caminhoFinal = caminhoFinal & strData
'Call CriaDiretorio(caminhoFinal)
'Call Copy_Folder(caminhoTemp, caminhoFinal)
'Call CriaDiretorio(caminhoFtp)
'Call Copy_Folder(caminhoFinal, caminhoFtp)
'Call RenameFileOrDir(caminhoTemp, caminhoFinal)
On Error GoTo PROC_ERR
Set fdr = objFSO.GetFolder(caminhoTemp)
fdr.Name = strData
objFile.Close
MsgBox "Your date is " & strData
End If
Next Atmt
PROC_ERR:
MsgBox "Error: " & Err.Number & ". " & Err.Description, , "RenameFileOrDir"
End Sub
'requires reference to Microsoft Scripting Runtime
Sub CriaDiretorio(strCaminho As String)
Dim strComp As String, strPart As String
If Not DiretorioExiste(strCaminho) Then
DiretorioCriado strCaminho
End If
End Sub
Function DiretorioCriado(ByVal caminho As String) As Boolean
DiretorioCriado = True
Dim FSO As New FileSystemObject
If DiretorioExiste(caminho) Then
Exit Function
Else
On Error GoTo DeadInTheWater
FSO.CreateFolder caminho
Exit Function
End If
DeadInTheWater:
MsgBox "A pasta não pode ser criada no caminho: " & caminho & ". Check se o caminho esta correto."
DiretorioCriado = False
Exit Function
End Function
Function DiretorioExiste(ByVal caminho As String) As Boolean
DiretorioExiste = False
Dim FSO As New FileSystemObject
If FSO.FileExists(caminho) Then DiretorioExiste = True
End Function