[Resolvido]Anexar arquivos para determinada pasta, criando a pasta com o COD de identificação e criando hiperlink para a pasta.

Boa tarde,

Sou um usuario Novo e Velho ao mesmo tempo do forum, sempre fiz pesquisas que me ajudaram muito por aqui. Mas essa duvida não consegui encontrar.

Tenho um BD, onde tenho um formulario de atualização. Na tabela tenho um campo anexo para os usuarios incluirem arquivos PDF, para pós visualização sobre a ocorrencia do processo.
O que preciso é que quando incluido o Anexo ele crie uma pasta em determinado diretório e incluia esse anexo nessa pasta. E me traga o hiperlink da pasta. Caso o usuario precise incluir outro anexo do registro ele incluia na pasta destinada aquele registro.

O campo de Identificação do Processo é IDPGO, ou seja a pasta precisa ser criada com esse campo.

Alguem tem como me dizer se é possivel.

Obrigado.

Boa tarde,

Ninguem para me ajudar?

Preciso apenas dessa informação para finalizar o BD!

Opa,

Pesquisei e conseguir criar a pasta com o nome do processo desejado com esse VB

Private Sub anexoBTN_Click()
Dim fso As Object
'habilite a referencia Microsoft Scripting Runtime
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Me.ID) Then ' verifica se já existe a pasta
If MsgBox("A pasta já existe, deseja abrir-la ?", vbOKCancel + vbCritical, "Pasta") = vbOK Then
' se responder Ok, abre a pasta que já existe
Application.FollowHyperlink ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Me.ID)
Else
Exit Sub
End If
Else
MkDir ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Me.ID) ' se não existir cria"
Application.FollowHyperlink ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Me.ID)
End If

End Sub

Agora preciso de ajuda para conseguir que ele pegue as informações do registro anexo e salve nessa pasta que ele verificou.

Alguem pode me ajudar?

Dê mais uma pesquisada na sala de códigos VBA que você encontra dicas para criar, copiar e deletar pastas e arquivos.

Criquio,

Já cacei em tudo...
Não encontro nada onde pegue o anexo do registro e salve via codigo.

Gente

Consegui algumas coisas que já daria.
Ficou assim

Private Sub anexoBTN_Click()
Dim Destino As String
Dim Arquivo As String
Dim fso As Object
'habilite a referencia Microsoft Scripting Runtime
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "")) Then ' verifica se já existe a pasta
If MsgBox("A pasta já existe, deseja abrir-la ?", vbOKCancel + vbCritical, "Pasta") = vbOK Then
' se responder Ok, abre a caixa de dialogo
'Irá abrir a caixa de diálogo
Arquivo = BuscarArquivo()
Destino = "\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "")
'Pega apenas o nome do arquivo
NomeDoArquivo = Mid(Arquivo, InStrRev(Arquivo, "\") + 1)

'Copia o arquivo para uma pasta mapeada no servidor
FileCopy Arquivo, Destino

Else
Exit Sub
End If
Else
MkDir ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "")) ' se não existir cria"
'Irá abrir a caixa de diálogo
Arquivo = BuscarArquivo()
Destino = "\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "")
'Pega apenas o nome do arquivo
NomeDoArquivo = Mid(Arquivo, InStrRev(Arquivo, "\") + 1)

'Copia o arquivo para uma pasta mapeada no servidor
FileCopy Arquivo, Destino

End If
Application.FollowHyperlink ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", ""))

End Sub

Aqui a Função que puxa o arquivo.

Function BuscarArquivo() As String
Dim ObjDialog As Object

'Define como uma caixa de diálogo do tipo msoFileDialogFilePicker
Set ObjDialog = Application.FileDialog(3)

'Define as propriedades do objeto e chama o método que exibe a caixa de diálogo
With ObjDialog
'Desabilita a seleção de vários arquivos
.AllowMultiSelect = False
'Muda o nome do botão de ação
.ButtonName = "Selecionar o arquivo"
'Muda o título da janela de diálogo
.Title = "Selecione um arquivo para armazenar..."

'Verifica se algo foi selecionado
If .Show Then
'Retorna o caminho onde está o arquivo
BuscarArquivo = "ObjDialog.SelectedItems"
End If

End With

Set ObjDialog = Nothing
End Function

Mas me da erro de Arquivo não encontrado.

Gente,

Consegui resolver sozinho.
Como não sou egoista ficou dessa forma.

Um modulo que ficou a função para pegar o caminho do arquivo a ser movido.

Option Compare Database

Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long

Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type

Function LaunchCD(strform As Form) As String
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
OpenFile.hwndOwner = strform.Hwnd
sFilter = "All Files (*.*)" & Chr(0) & "*.*" & Chr(0) & _
"JPEG Files (*.JPG)" & Chr(0) & "*.JPG" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
OpenFile.lpstrInitialDir = "C:\"
OpenFile.lpstrTitle = "Select a file using the Common Dialog DLL"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If Not lReturn = 0 Then

LaunchCD = Trim(Left(OpenFile.lpstrFile, InStr(1, OpenFile.lpstrFile, vbNullChar) - 1))

Else
MsgBox "Voce não selecionou nenhum arquivo!", vbInformation, _
"UpLoad Cancelado"
End If
End Function


Depois a função na função ao clicar do Botão

Private Sub anexoBTN_Click()
Dim Destino As String
Dim Arquivo As String
Dim fso As Object
'habilite a referencia Microsoft Scripting Runtime
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "")) Then ' verifica se já existe a pasta
If MsgBox("A pasta já existe, adicionar arquivos?", vbOKCancel + vbCritical, "Pasta") = vbOK Then
' se responder Ok, abre a caixa de dialogo
'Irá abrir a caixa de diálogo
Arquivo = LaunchCD(Me)
Destino = "\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "") & "/" & Mid(Arquivo, InStrRev(Arquivo, "\") + 1)
'Copia o arquivo para uma pasta mapeada no servidor
On Error GoTo Erro
FileCopy Arquivo, Destino

Else
Exit Sub
End If
Else
If MsgBox("Você deseja criar uma pasta para adicionar arquivos?", vbOKCancel + vbCritical, "Pasta") = vbOK Then
MkDir ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "")) ' se não existir cria"
'Irá abrir a caixa de diálogo
Arquivo = LaunchCD(Me)
Destino = "\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", "") & "/" & Mid(Arquivo, InStrRev(Arquivo, "\") + 1) 'Pega apenas o nome do arquivo

'Copia o arquivo para uma pasta mapeada no servidor
On Error GoTo Erro
FileCopy Arquivo, Destino

End If
End If
Application.FollowHyperlink ("\\10.100.1.15\financeiro_lfg\contasreceber\RESTITUIÇÃO\Banco de Dados\ANEXOS\" & Replace(Me.IDPGOTXTT, "/", ""))

Erro:
DoCmd.CancelEvent

End Sub

Deu certinho obrigado.

Ótimo. Só faltou clicar no botão Resolvido. Sempre que resolver uma dúvida, clique nesse botão.

Dessa vez eu mesmo clico.

Opa, desculpa ai....
Não esqueço da próxima...