[Resolvido]Reletorio PDF na pasta certa

ola pessoa estou com a seguinte situação, tenho um formulário que salva o relatório em PDF na pasta  C:\BlocoSystem\CuponÀprazo, já com a data e hora.
mais preciso criar uma estrutura igual a essa imagem
https://www.dropbox.com/s/3ze9i142jk3qw6i/estrutuara.jpg
caso não visualize a imagen segue um esquema
C:\BlocoSystem\CuponÀprazo\2014
Jan
Fev
Mar
Abr
Mai
Jun
e assim por diante
e se a pasta ano referente e mês, não existir criar pastas e sub pasta e salvar cada relatório dependendo da data na pasta certa.
só que não sei nem por onde começa se aguem poder ajuda ou tiver algum exemplo desde já agradeço.

Tens de escrever no vba o local

Qual é o codigo que utilizas?

Eu utilizo este:

Código:

Private Sub Comando570_Click() 'Comando570 é o nome do meu butão
Dim strArquivo As String
Dim strLocal As String
Dim strReportName As String
Dim numCop As Integer
DoCmd.OpenReport "Oficio Normal1", acViewPreview, , "[001] = " & [001] 'Oficio Normal1 - nome do meu relatório e [001] chave primária
DoCmd.Maximize
strReportName = Replace([7], "/", "-") & "_" & Me![001] & ".pdf" 'aqui guardo com o nome que quero, neste caso com o que escrevo no campo 7 alterando "/" para "-" mais "_" e a chave primária, visto eu no campo 7 escrever tipo 123/12-SR, ficando tipo 123-12-SR_4321
strLocal = CurrentProject.Path & "\Oficios Expedidos\" & strArquivo 'aqui guarda na pasta "oficios expedidos" que criei dentro da pasta onde tenho a bd
DoCmd.OutputTo acOutputReport, "Oficio Normal1", acFormatPDF, strLocal + strReportName, True 'abre o pdf
DoCmd.Close 'fecha a visualização do relatório access

vê aqui:
http://maximoaccess.forumeiros.com/t9034-resolvidorelatorio-em-pdf-gera-salva-mas-nao-fica-aberto

no momento utilizo esse


DoCmd.OutputTo acOutputReport, "NOTA FISCAL", acFormatPDF, "C:\SGGV\Documentos\CuponÀprazo/" & Me.CodCliente.Column(1) & " -(Data " & Format(Now, "mm-yyyy") & ")" & " -(Hora " & Format(Time, "hh-mm-ss") & ")" & ".pdf"

só que eu queria que ele salva-se na pasta com o ano e o mês
tipo assim se eu salva-se hoje seria na pasta 2014 e na subpasta Fev, se salva-se mês que vem seria na pasta 2014 subpasta Mar, se eu salva-se ano que vem e não tive-se a pasta criar a pasta 2015 e todas as subpastas e a sim por diante.

já to com algumas ideias vou tentar escrever os códigos só que sou novato em VBA se vcs tiverem ideias ou exemplos  fico no aguardo.

ola pessoal ja consegui criar a pasta automagicamente conforme o ano

'num botão ou procedimento
Dim strLocal As String
Dim StrPasta As String
StrPasta = Format(Now, "yyyy")
strLocal = CurrentProject.Path & "\Documentos\CuponÀvista\" '& strArquivo 'aqui guarda na pasta "oficios expedidos" que criei dentro da pasta onde tenho a bd
DoCmd.OutputTo acOutputReport, "NOTA FISCAL", acFormatPDF, strLocal + Me.CodCliente.Column(1) & " -(Data " & Format(Now, "mm-yyyy") & ")" & " -(Hora " & Format(Time, "hh-mm-ss") & ")" & ".pdf"

If Dir(strLocal & "\" & StrPasta) <> "" Then
msgbox "Esta pasta já existe"

Else
MkDir (strLocal & "\" & StrPasta)
End If
agora queria criar a subpasta com mês atual e salvar p PDF na pasta conforme o mês exato.
desde já agradeço.

ola pessoal boas novas estou avançado pois já consegui criar a pasta com o ano atual e o mês atual agora só falta conseguir colocar cada PDF na pasta certa loga abaixo segue a função que estou tentando desenvolver caso os amigos poderem me ajudar desde já agradeço.

Function SalvarCupom1()
'Dim strArquivo As String
Dim strLocal As String
Dim StrPasta As String
Dim StrSubPasta As String
StrPasta = Format(Now, "yyyy")
StrSubPasta = Format(Now, "mm")
strLocal = CurrentProject.Path & "\Documentos\CuponÀvista\" 'aqui guarda na pasta "oficios expedidos" que criei dentro da pasta onde tenho a bd
DoCmd.OutputTo acOutputReport, "Cupom", acFormatPDF, strLocal + Me.CodCliente.Column(1) & " -(Data " & Format(Now, "mm-yyyy") & ")" & " -(Hora " & Format(Time, "hh-mm-ss") & ")" & ".pdf"

If Dir(strLocal & "\" & StrPasta) <> "" Then
msgbox "Esta pasta já existe"

Else
MkDir (strLocal & "\" & StrPasta)
MkDir (strLocal & "\" & StrPasta & "\" & StrSubPasta)
End If
End Function

Este é o codigo que utilizo abre uma mensagem de sim não cancelar, apos clicar em sim cria-me uma pasta com o nome do registo e dentro dela gera-me o pdf.

Estada-o e tenta adaptar, é parecido com o que te enviei antes só com algumas alterações tipo criar a pasta podes usar isso para o mês ou tiras essa parte e colocas como no código anterior. dá-me ainda a opção de imprimir e gerar ou não o PDF.

Código:

Private Sub Comando277_Click()
Dim strArquivo As String
Dim strLocal As String
Dim fso As Object
Dim strDocumento As String
DoCmd.Save
Select Case MsgBox("DESEJA CRIAR PDF?", vbInformation + vbYesNoCancel, [CodBarra])
Case vbYes
DoCmd.OpenReport "NUIPCSREG_5", acViewPreview, , "[CódigoDoProduto] = " & [CódigoDoProduto]
DoCmd.Maximize
strLocal = CurrentProject.Path & "\Inquéritos\" & Replace(Replace(Me!CodBarra, "/", "_"), ".", "-") & "\"
strDocumento = "NUIPCSREG_5"
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(strLocal) Then ' verifica se ja existe a pasta e subpasta
DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal & "Capa Resumo" & " " & Replace(Me!CodBarra, "/", "_") & " _ " & Me![CódigoDoProduto] & ".pdf", False
Else
MkDir strLocal ' se nao existir cria
DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal & "Capa Resumo" & " " & Replace(Me!CodBarra, "/", "_") & " _ " & Me![CódigoDoProduto] & ".pdf", False
End If
Dim numCop As Integer
    numCop = InputBox("Informe a quantidade de cópias: ", "IMPRIMIR") 'Valor este que pode ser obtido por outro meios
    DoCmd.PrintOut acPrintAll, , , acHigh, numCop 'Linha simplificada para a impressão
DoCmd.Close
Case vbNo
DoCmd.OpenReport "NUIPCSREG_5", acViewPreview, , "[CódigoDoProduto] = " & [CódigoDoProduto]
DoCmd.Maximize
    numCop = InputBox("Informe a quantidade de cópias: ", "IMPRIMIR") 'Valor este que pode ser obtido por outro meios
    DoCmd.PrintOut acPrintAll, , , acHigh, numCop 'Linha simplificada para a impressão
DoCmd.Close
Case vbCancel
End Select
End Sub

ola toyebom e amigos do fórum estou adaptando o seu código mas só consigo criar a pasta referente ao ano(2014) não consigo cria a subpasta do mês(3)
fica a função abaixo adaptada.
desde ja agradeço a todos e uma boa noite.

Function SalvarC3()

   Dim strArquivo As String
   Dim strLocal3 As String
   Dim fso As Object
   Dim strDocumento As String
       
       Dim StrPasta As String
      Dim StrSubPasta As String
       StrPasta = Format(Now, "yyyy")
       StrSubPasta = Format(Now, "mm")
   
   DoCmd.Save
   Select Case MsgBox("DESEJA CRIAR PDF?", vbInformation + vbYesNoCancel) ', [CodBarra])
   Case vbYes

   strLocal3 = CurrentProject.Path & "\Documentos\CuponÀprazo\" & Replace(Replace(StrPasta, "/", "_"), ".", "-") & "\"

   strDocumento = "Cupom"
   

   Set fso = CreateObject("Scripting.FileSystemObject")
   If fso.folderexists(strLocal3) Then ' verifica se ja existe a pasta e subpasta
   DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal3 & Cliente & "- Mês - " & Replace(StrSubPasta, "/", "_") & "  -Hora " & Format(Time, "hh-mm-ss") & "" & ".pdf", False

   Else
   MkDir strLocal3 ' se nao existir cria
   DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal3 & Cliente & "- Mês - " & Replace(StrSubPasta, "/", "_") & "  -Hora " & Format(Time, "hh-mm-ss") & "" & ".pdf", False
   End If
   
   Case vbNo
   DoCmd.Close
   Case vbCancel
   End Select
   End Function

já tentaste retirar os False que colocaste? Qual é o resultado?
Se conseguias na mensagem anterior é só acrescentar a linha que cria o pdf

ola amigo o pdf gera tranquilo e salva na pasta referente ao ano(2014) mais não cria a subpasta referente ao mês atual(03)
a minha ideia e separa os cupons por ano e mês.
desde ja agradeço

ola toyebom e amigos de plantão modifiquei a seguente linha e deu certo.

Function SalvarPDF()

Dim strArquivo As String
Dim strLocal3 As String
Dim fso As Object
Dim strDocumento As String

Dim StrPasta As String
Dim StrSubPasta As String
StrPasta = Format(Now, "yyyy")
StrSubPasta = Format(Now, "mm")
DoCmd.Save
Select Case MsgBox("DESEJA CRIAR PDF?", vbInformation + vbYesNoCancel) ', [CodBarra])
Case vbYes

'linha modificada
strLocal3 = CurrentProject.Path & "\Documentos\CuponÀprazo\" & Replace(Replace(StrPasta, "/", "_"), ".", "-") & "\" & "\" & Replace(Replace(StrSubPasta, "/", "_"), ".", "-") & "\"


strDocumento = "Cupom"


Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(strLocal3) Then ' verifica se ja existe a pasta e subpasta
DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal3 & Cliente & "- Mês - " & Replace(StrSubPasta, "/", "_") & " -Hora " & Format(Time, "hh-mm-ss") & "" & ".pdf", False

Else
MkDir strLocal3 ' se nao existir cria
DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal3 & Cliente & "- Mês - " & Replace(StrSubPasta, "/", "_") & " -Hora " & Format(Time, "hh-mm-ss") & "" & ".pdf", False
End If

Case vbNo
DoCmd.Close
Case vbCancel
End Select
End Function

OK só mais uma coisa, a parte Replace(Replace(Me!CodBarra, "/", "_"), ".", "-") & "\" é para substituir / por _ e , e . por - no nome do pdf já que esses caracteres dão erro a guardar, se calhar não faz falta para ti, mas se não te estorvam ok deixa ficar.

ola amigo fiz umas mudanças e ficou perfeito
veja
Function ANO() 'função para criar a pasta referente ao ano atual no meu caso(2014)
On Error Resume Next
Dim strLocalAno As String
Dim StrPasta As String
StrPasta = Format(Now, "yyyy")
strLocalAno = CurrentProject.Path & "\Documentos\CuponÀprazo\" '& strArquivo 'aqui guarda na pasta "oficios expedidos" que criei dentro da pasta onde tenho a bd
If Dir(strLocalAno & "\" & StrPasta) <> "" Then

Else
MkDir (strLocalAno & "\" & StrPasta)
End If
End Function
Function SalvarPDF()
ANO ' ativa a função ano
Dim strArquivo As String
Dim strLocal3 As String
Dim strLocal4 As String
Dim fso As Object

Dim strDocumento As String
Dim StrPasta As String
Dim StrSubPasta As String
Dim StrDias As String

StrPasta = Format(Now, "yyyy")
StrSubPasta = Format(Now, "mm")
StrDias = Format(Now, "dd")

DoCmd.Save
strLocal3 = CurrentProject.Path & "\Documentos\CuponÀprazo\" & Replace(Replace(StrPasta, "/", "_"), ".", "-") & "\" & "\" & "\" & "\" & Replace(Replace(StrSubPasta, "/", "_"), ".", "-") & "\"



strDocumento = "Cupom"

Set fso = CreateObject("Scripting.FileSystemObject")
If fso.folderexists(strLocal3) Then ' verifica se ja existe a pasta e subpasta
DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal3 & Cliente & " - Dias - " & Replace(StrDias, "/", "_") & " - Hora " & Format(Time, "hh-mm-ss") & "" & ".pdf", False

Else

MkDir strLocal3

DoCmd.OutputTo acOutputReport, strDocumento, acFormatPDF, strLocal3 & Cliente & " - Dias - " & Replace(StrDias, "/", "_") & " - Hora " & Format(Time, "hh-mm-ss") & "" & ".pdf", False

End If

DoCmd.Close
End Function