[Resolvido]Criar Pasta

Bom dia a todos,

Desde já desejo um feliz natal a todos.

Preciso de ajuda em relação a criação de um código em vba.
Há alguma forma para quando eu carregar num botão em access, ele criasse uma pasta e guarda-se a tabela em excel nessa pasta com o nome de um campo?

já tenho algo mais ou menos, só não me cria a pasta e guarda lá os ficheiros.

Private Sub Command253_Click()
Dim strArquivo1 As String
Dim strArquivo As String
Dim strLocal As String
Dim strLocal1 As String
strArquivo = "Interno -" & Me!Text339 & ".pdf"
strArquivo1 = "Excel -" & Me!Text339 & ".xlsx"
strLocal = CurrentProject.Path & "\PDF\" & strArquivo
strLocal1 = CurrentProject.Path & "\PDF\" & strArquivo1
DoCmd.OutputTo acOutputTable, "Folha1", acFormatXLSX, strLocal1, False
DoCmd.Close acTable, "Folha1"
DoCmd.OutputTo acOutputReport, "interno1", acFormatPDF, strLocal, False
DoCmd.Close acReport, "interno1"
End Sub

agradeço...   

JPaulo tem um exemplo de criar pasta com subpasta mas não encontrei, mas veja este topico

http://maximoaccess.forumeiros.com/t15752-resolvidocriar-sub-pasta

Boa sorte

Bom dia,

obg pela dica scandinavo, mas não me ajudo muito nakilo que eu pretendo.

alterei um pouco o codigo que vi no exemplo do JP mas algo não ta a funcionar bem.

Caso eu tenha a pasta ja criada, o codigo cria o ficheiro PDF, caso a pasta não esteja criada, ele cria só a pasta mas não introduze o ficheiro pretendido nessa pasta criada.

Private Sub Command347_Click()
Dim strArquivo As String
Dim strArquivo1 As String
Dim strLocal1 As String
Dim strLocal2 As String
Dim dir, folder, fso
Set fso = CreateObject("Scripting.FileSystemObject")
strArquivo = "Interno -" & Me.Text339 & ".pdf"
If fso.folderexists(CurrentProject.Path & "\PDF\" & Me.Text339) Then
strArquivo = "Interno -" & Me.Text339 & ".pdf" nome ficheiro para introduzir na pasta criada
strLocal1 = CurrentProject.Path & "\PDF\" & strArquivo
DoCmd.OutputTo acOutputReport, "interno8", acFormatPDF, strLocal1, False
DoCmd.Close acReport, "interno8"
End If
If Not fso.folderexists(CurrentProject.Path & "\PDF\" & Me.Text339) Then '
MsgBox "A pasta não existe. A mesma será criada."
MkDir CurrentProject.Path & "\PDF\" & Me.Text339
strArquivo1 = "Interno -" & Me.Text339 & ".pdf"
strLocal2 = CurrentProject.Path & Me.Text339 & strArquivo1
 DoCmd.OutputTo acOutputReport, "interno8", acFormatPDF, strLocal2, False
DoCmd.Close acReport, "interno8"
End If
End Sub

Obrigado

Achei mais fácil mostrar uma função que utilizo e seta funcionando

Dim strArquivo As String
Dim strLocal As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strArquivo = "Pedido" & "_" & Format$(Now(), "dd mm yyyy") & ".pdf"
'Local do banco de dados e pasta
strLocal = CurrentProject.Path & "\RelatorioNovo\" & strArquivo

If fso.folderexists(CurrentProject.Path & "\RelatorioNovo") Then
'Se a pasta existe
MsgBox "A pasta RelatorioNovo já existe..." 'Desabilite esta mensagem
'salva o relatorio
DoCmd.OutputTo acOutputReport, "Pedido", acFormatPDF, strLocal

MsgBox "Arquivo gerado com sucesso em " & CurrentProject.Path & "\RelatorioNovo\" & "" & vbCrLf & vbCrLf & _
"" & vbCrLf & "Pedido" & "_" & Format$(Now(), "dd mm yyyy") & ".Pdf" & vbCrLf & "", vbInformation, "Enviar para PDF"
Exit Sub
Else
'Se a Pasta não existe, cria.
MsgBox "A pasta RelatorioNovo vai ser criada..." 'Desabilite esta mensagem
MkDir CurrentProject.Path & "\RelatorioNovo"
'salva o relatorio
DoCmd.OutputTo acOutputReport, "Pedido", acFormatPDF, strLocal

MsgBox "Arquivo gerado com sucesso em " & CurrentProject.Path & "\RelatorioNovo\" & "" & vbCrLf & vbCrLf & _
"" & vbCrLf & "Pedido" & "_" & Format$(Now(), "dd mm yyyy") & ".Pdf" & vbCrLf & "", vbInformation, "Enviar para PDF"

End If

a sua função esta façil de ser corrigida......


Boa sorte

Mais uma vez muito obrigado pela ajuda scandinavo.

Já alterei o codigo para a minha BD e funcionou na perfeição.
Para ficar mesmo perfeito era que em vez de ter que dar um nome a uma pasta fixa "\RelatorioNovo" fosse possivel assumir a Data "Format$(Now(), "dd mm yyyy")" como nome da pasta. isso porque ficava uma pasta com os ficheiros organizados por data.

Obrigado pelo tempo que disponibiliza comigo.   

Agora acho que não falta mais nada rsrsrsrsrsrsrsr.....
tudo desenvolvido a partir do exemplo de JPaulo "criar pasta com sub pasta"

Dim strArquivo As String
Dim strLocal As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strArquivo = "Pedido" & "_" & Format$(Now(), "dd mm yyyy") & ".pdf"
'Local do banco de dados
strLocal = CurrentProject.Path & "\" & Format$(Now(), "dd mm yyyy") & "\" & strArquivo

If fso.folderexists(CurrentProject.Path & "\" & Format$(Now(), "dd mm yyyy")) Then
'Se a pasta existe
MsgBox "A pasta já existe..." 'Desabilite esta mensagem
'salva o relatorio
DoCmd.OutputTo acOutputReport, "Pedido", acFormatPDF, strLocal

MsgBox "Arquivo gerado com sucesso em " & CurrentProject.Path & "\" & Format$(Now(), "dd mm yyyy") & "" & vbCrLf & vbCrLf & _
"" & vbCrLf & "Pedido" & "_" & Format$(Now(), "dd mm yyyy") & ".Pdf" & vbCrLf & "", vbInformation, "Enviar para PDF"
Exit Sub
Else
'Se a Pasta não existe, cria com a data do dia
MsgBox "A pasta vai ser criada..." 'Desabilite esta mensagem
MkDir CurrentProject.Path & "\" & Format$(Now(), "dd mm yyyy")
'salva o relatorio
DoCmd.OutputTo acOutputReport, "Pedido", acFormatPDF, strLocal

MsgBox "Arquivo gerado com sucesso em " & CurrentProject.Path & "\" & Format$(Now(), "dd mm yyyy") & "" & vbCrLf & vbCrLf & _
"" & vbCrLf & "Pedido" & "_" & Format$(Now(), "dd mm yyyy") & ".Pdf" & vbCrLf & "", vbInformation, "Enviar para PDF"

End If


Boa sorte

Bom dia,

Venho por este meio agradeçer ao scandinavo pela ajuda prestada.
o ultimo codigo disponibilizado por ele fico a funcionar após umas pequenas alterações.   

vou deixar aqui a alteração que efeituei, caso alg precise.
o codigo abaixo cria uma pasta e um ou dois ficheiros dependentemente do utilizador.
Pode não estar la muito bem construido, mas funciona na perfeição.

mais uma vez OBRIGADO.

Private Sub Command170_Click() ' nome do buttão
Dim strArquivo As String
Dim strLocal As String
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
strArquivo = "Interno - " & "_" & Me.Text339 & ".pdf"
strLocal = CurrentProject.Path & "\PDF\" & Me.Text126 & "\" & strArquivo
Dim strArquivo1 As String
Dim strLocal1 As String
strArquivo1 = "Excel -" & "_" & Me.Text339 & ".xlsx"
strLocal1 = CurrentProject.Path & "\PDF\" & Me.Text126 & "\" & strArquivo1
Dim Msg, Style, Title, Help, Ctxt, Response, MyString
Msg = "Deseja guardar a base de dados em Excel?"
Style = vbYesNo + vbCritical + vbDefaultButton2
Title = "Guardar Base Dados em Excel"
Help = "Ajuda.HLP"
Ctxt = 1000
Response = MsgBox(Msg, Style, Title, Help, Ctxt)
If Response = vbYes Then
MyString = "Sim"
If fso.folderexists(CurrentProject.Path & "\PDF\" & Me.Text126) Then
DoCmd.OutputTo acOutputReport, "interno8", acFormatPDF, strLocal, False
DoCmd.OutputTo acOutputTable, "Folha1", acFormatXLSX, strLocal1, False
MsgBox "Arquivo gerado com sucesso.", vbInformation, "Enviar para Pasta Arquivo"
CurrentDb.Execute "delete * from Folha1"
Form_sub_report_metros.Requery
Exit Sub
Else
MkDir CurrentProject.Path & "\PDF\" & Me.Text126
DoCmd.OutputTo acOutputReport, "interno8", acFormatPDF, strLocal
MsgBox "Arquivo gerado com sucesso.", vbInformation, "Enviar para Pasta Arquivo"

DoCmd.OutputTo acOutputTable, "Folha1", acFormatXLSX, strLocal1, False
DoCmd.Close acTable, "Folha1"
CurrentDb.Execute "delete * from Folha1"
Text333.Value = Null
Text126.Value = Null
Text124.Value = Null
Form_sub_report_metros.Requery
End If
Else
MyString = "Não"
If fso.folderexists(CurrentProject.Path & "\PDF\" & Me.Text126) Then
DoCmd.OutputTo acOutputReport, "interno8", acFormatPDF, strLocal
DoCmd.OutputTo acOutputTable, "Folha1", acFormatXLSX, strLocal1, False
MsgBox "Arquivo gerado com sucesso.", vbInformation, "Enviar para Pasta Arquivo"
CurrentDb.Execute "delete * from Folha1"
Form_sub_report_metros.Requery
Exit Sub
Else
MkDir CurrentProject.Path & "\PDF\" & Me.Text126
DoCmd.OutputTo acOutputReport, "interno8", acFormatPDF, strLocal
DoCmd.OutputTo acOutputTable, "Folha1", acFormatXLSX, strLocal1, False
MsgBox "Arquivo gerado com sucesso.", vbInformation, "Enviar para Pasta Arquivo"
CurrentDb.Execute "delete * from Folha1"
Text333.Value = Null
Text126.Value = Null
Text124.Value = Null
Form_sub_report_metros.Requery
End If
End If
Form_sub_report_metros.Requery
End Sub

Valeu pelo retorno


Boa sorte