[Resolvido]Exportar Consulta via VBA com a data atual

Prezados, Bom dia!!!

Montei o código abaixo para exportar uma consulta para excel, porém, não estou conseguindo fazer duas coisas;

1 - Usuário escolher o local a onde ele quer salvar.
2- Abrir o arquivo apos a exportação automaticamente.

código:

Código:

DoCmd.OutputTo acOutputQuery, "QFAM_461", "Excel97-Excel2003Workbook(*.xls)", "C:\Users\sidney.silva\Desktop\" & "QFAM_461_C10" & "_" & Format(Now, "ddmmyy") & ".xls", False, "", 0, acExportQualityPrint

o código está exportando normalmente, como o nome do arquivo que eu quero e com a data do dia. Desde de já agradeço..

att;

Sidney

Bom dia, Tente o seguinte:

1º Passo

Cole o seguinte código em um módulo:

Código:


Public blnSair As Boolean

Type tagOPENFILENAME
    lStructSize As Long
    hwndOwner As Long
    hInstance As Long
    strFilter As String
    strCustomFilter As String
    nMaxCustFilter As Long
    nFilterIndex As Long
    strFile As String
    nMaxFile As Long
    strFileTitle As String
    nMaxFileTitle As Long
    strInitialDir As String
    strTitle As String
    Flags As Long
    nFileOffset As Double
    nFileExtension As Double
    strDefExt As String
    lCustData As Long
    lpfnHook As Long
    lpTemplateName As String
   
End Type

Declare Function aht_apiGetOpenFileName Lib "comdlg32.dll" _
    Alias "GetOpenFileNameA" (OFN As tagOPENFILENAME) As Boolean

Declare Function aht_apiGetSaveFileName Lib "comdlg32.dll" _
    Alias "GetSaveFileNameA" (OFN As tagOPENFILENAME) As Boolean

Declare Function CommDlgExtendedError Lib "comdlg32.dll" () As Long

Global Const ahtOFN_READONLY = &H1

Global Const ahtOFN_OVERWRITEPROMPT = &H2

Global Const ahtOFN_HIDEREADONLY = &H4

Global Const ahtOFN_NOCHANGEDIR = &H8

Global Const ahtOFN_SHOWHELP = &H10

Global Const ahtOFN_NOVALIDATE = &H100

Global Const ahtOFN_ALLOWMULTISELECT = &H200

Global Const ahtOFN_EXTENSIONDIFFERENT = &H400

Global Const ahtOFN_PATHMUSTEXIST = &H800

Global Const ahtOFN_FILEMUSTEXIST = &H1000

Global Const ahtOFN_CREATEPROMPT = &H2000

Global Const ahtOFN_SHAREAWARE = &H4000

Global Const ahtOFN_NOREADONLYRETURN = &H8000

Global Const ahtOFN_NOTESTFILECREATE = &H10000

Global Const ahtOFN_NONETWORKBUTTON = &H20000

Global Const ahtOFN_NOLONGNAMES = &H40000

Global Const ahtOFN_EXPLORER = &H80000

Global Const ahtOFN_NODEREFERENCELINKS = &H100000

Global Const ahtOFN_LONGNAMES = &H200000

Function getOpenFile(Optional varDirectory As Variant, _
    Optional varTitleForDialog As Variant) As Variant

    Dim strFilter                              As String
    Dim lngFlags                                As Long
    Dim varFileName                            As Variant

    lngFlags = ahtOFN_FILEMUSTEXIST Or _
                ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
               
    If IsMissing(varDirectory) Then
   
        varDirectory = ""
       
    End If
   
    If IsMissing(varTitleForDialog) Then
   
        varTitleForDialog = ""
       
    End If

    strFilter = ahtAddFilterItem(strFilter, _
                "Arquivos Microsoft Excel (*.XLS)", "*.csv")

    varFileName = ahtCommonFileOpenSave( _
                    OpenFile:=True, _
                    InitialDir:=varDirectory, _
                    Filter:=strFilter, _
                    Flags:=lngFlags, _
                    DialogTitle:=varTitleForDialog)

    If Not IsNull(varFileName) Then
   
        varFileName = TrimNull(varFileName)
       
    End If
   
    getOpenFile = varFileName
   
End Function

Function ahtCommonFileOpenSave( _
            Optional ByRef Flags As Variant, _
            Optional ByVal InitialDir As Variant, _
            Optional ByVal Filter As Variant, _
            Optional ByVal FilterIndex As Variant, _
            Optional ByVal DefaultExt As Variant, _
            Optional ByVal Filename As Variant, _
            Optional ByVal DialogTitle As Variant, _
            Optional ByVal hwnd As Variant, _
            Optional ByVal OpenFile As Variant) As Variant

    Dim OFN                                As tagOPENFILENAME
    Dim strFileName                        As String
    Dim strFileTitle                        As String
    Dim fResult                            As Boolean

    If IsMissing(InitialDir) Then InitialDir = ""
    If IsMissing(Filter) Then Filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = "txt"
    If IsMissing(Filename) Then Filename = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    If IsMissing(hwnd) Then hwnd = Application.hWndAccessApp
    If IsMissing(OpenFile) Then OpenFile = True

    strFileName = Left(Filename & String(256, 0), 256)
    strFileTitle = String(256, 0)
   
   

    With OFN
        .lStructSize = Len(OFN)
        .hwndOwner = hwnd
        .strFilter = Filter
        .nFilterIndex = FilterIndex
        .strFile = strFileName
        .nMaxFile = Len(strFileName)
        .strFileTitle = strFileTitle
        .nMaxFileTitle = Len(strFileTitle)
        .strTitle = DialogTitle
        .Flags = Flags
        .strDefExt = DefaultExt
        .strInitialDir = InitialDir
        .hInstance = 0
        .strCustomFilter = ""
        .nMaxCustFilter = 0
        .lpfnHook = 0
        'New for NT 4.0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
       
    End With
   

    If OpenFile Then
   
        fResult = aht_apiGetOpenFileName(OFN)
       
    Else
   
        fResult = aht_apiGetSaveFileName(OFN)
       
    End If


    If fResult Then

        If Not IsMissing(Flags) Then
       
            Flags = OFN.Flags
            ahtCommonFileOpenSave = TrimNull(OFN.strFile)
           
        Else
            ahtCommonFileOpenSave = "" 'alterado por JR.
           
        End If
       
    End If
   
End Function

Function ahtAddFilterItem(strFilter As String, _
                          strDescription As String, Optional _
                          VarItem As Variant) As String
   
    If IsMissing(VarItem) Then VarItem = "*.*"
    ahtAddFilterItem = strFilter & _
                strDescription & vbNullChar & _
                VarItem & vbNullChar
End Function


Private Function TrimNull(ByVal strItem As String) As String

    Dim intPos                              As Double
   
    intPos = InStr(strItem, vbNullChar)
   
    If intPos > 0 Then
   
        TrimNull = Left(strItem, intPos - 1)
       
    Else
   
        TrimNull = strItem
       
    End If
   
End Function

Function AbreCaixaDialogo() As String

    Dim strFilter                          As String
    Dim strCurDir                          As String
   
    'para utilizar defina o filtro tipo de arquivo conforme abaixo
    '  TipoArquivo = "*_re.txt"
    '  strFilter = ahtAddFilterItem(strFilter, "Arquivos de Registro de Exportação (*_re.txt)", TipoArquivo)
    '  ou
   
    strFilter = ahtAddFilterItem(strFilter, "")
   
    'Para Utilizar:
   
    AbreCaixaDialogo = ahtCommonFileOpenSave(, strCurDir, strFilter, , , _
                      , "Selecione o arquivo desejado", , True)
   
End Function



2º Passo

Em um formulário, insira o seguinte código a um objeto:

Código:



Private Sub Bt_Exportar_Click()

    Dim strCurDir
    Dim FormatoArquivo
    Dim NOME_ARQUIVO
   
On Error GoTo TRATA_ERRO

    NOME_ARQUIVO = ahtCommonFileOpenSave(, _
                                        strCurDir, _
                                        "Pasta de Trabalho do Excel", _
                                        FormatoArquivo, _
                                        "", _
                                        "NomeMinhaConsulta" & Now(), _
                                        "Salvar como", , False)

    If NOME_ARQUIVO = "" Then
                   
      Exit Sub
                   
      Else
           
          DoCmd.TransferSpreadsheet acExport, acSpreadsheetTypeExcel12, _
          "NomeMinhaConsulta", NOME_ARQUIVO, True
                                                                                           
          MsgBox ("Dados exportados com sucesso !"), _
                  vbInformation, "Meu Projeto"
                     
    End If
   
    Exit Sub

'---------------------------------------------------------------------------------------------------------
' 1. Finaliza o procedimento, caso haja algum erro.
'---------------------------------------------------------------------------------------------------------
   
TRATA_ERRO:

    Call Msgbox_Trata_Erro

    Exit Sub

End Sub



Tente ai me retorne, caso dê certo, não esquece de dar como Resolvido o tópico !!!

Enjoy!!!

Amigo , Boa tarde!!

Consegui resolver com umas pequenas mudanças, segue abaixo:

Código:

DoCmd.OutputTo acOutputQuery, "QFAM_461", "Excel97-Excel2003Workbook(*.xls)", "QFAM_461_C10" & "_" & Format(Now, "ddmmyy") & ".xls", True, "", , acExportQualityPrint

mesmo assim muito obrigado.

att;

Sidney

Não esquece de dar como Resolvido !