Output multiple reports to one word file 1

[titanl]

Hi everyone,

Is there a way to output multiple access reports to one single word file? I am able to output single report to .rtf without any problems by using the following code:

Private Sub EditFinalsInWord_Click()

    Dim strCurrentPath As String
    strCurrentPath = Application.CurrentProject.Path & "\"
   
    DoCmd.OutputTo acOutputReport, "Finals", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Finals Programme.rtf", True

End Sub

In all I have some 18 reports to output into a single Word file. I have tried using sub-reports which could solve the problem if there is no other solution, but was just wondering if the code above could be modified.

Thanks

 

[kjv1611]

It would seem there are better methods, but why not spitting out all the reports to Word format, then immediately using the Word application object to open them all, and copy/paste one to another until you have them all in one document? Of course, after you finish, you delete the originals.

--

"If to err is human, then I must be some kind of human!" -Me

 

[titanl]

Hi kjv1611,

Actually this is what I've been doing for the past year or so. Nonetheless, thanks for the reply.

 

[MajP]

I think the easiest would be to write the code to output all 18 into a single folder. Then write the code in a Word template to "insert text" from all 18 files. You can set the template up to run the code on opening the word template.

 

[titanl]

Hi MajP,
Thanks for the reply and suggestion. I have already write the code to output all reports into a single folder which is working beautifully. However, due to my limited experience in writing code in Word Application, I have use a Macro to insert all 18 files in a Word template. The macro is doing the job alright, but compared to the vba code in Access which actually uses the Application.CurrentProject.Path, I'm afraid that if the Master Folder location is change the macro in the word template will produce an error. Please find below the code in Access and the macro in Word.

1. Access code

Private Sub SendAllToWord_Click()

    Dim strCurrentPath As String
    strCurrentPath = Application.CurrentProject.Path & "\"
   
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GU8", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G U 8.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BU8", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B U 8.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GU10", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G U 10.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BU10", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B U 10.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GU12", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G U 12.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BU12", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B U 12.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GU14", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G U 14.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BU14", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B U 14.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GU16", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G U 16.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BU16", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B U 16.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GU18", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G U 18.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BU18", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B U 18.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_GOpen", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-G Open.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BOpen", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-B Open.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BestPrimary", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-Best Primary.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_SpecialPrimaryU14", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-Special Primary U 14.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BestSecondary", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-Best Secondary.rtf", False
    DoCmd.OutputTo acOutputReport, "RankAndMedalStandings_BestPostSecondary", acFormatRTF, Application.CurrentProject.Path & "\Finals\Finals_Data\Rank And Medal Standings-Best Post Secondary.rtf", False

End Sub

2. Word macro

Sub InsertRanking()
'
' InsertRanking Macro
'
'
    ChangeFileOpenDirectory _
        "C:\Users\Titan\Desktop\NSAC_Master\Finals\Finals_Data\"
    Selection.InsertFile FileName:= _
        "RankAndMedalStandings_BestPostSecondary.rtf", Range:="", _
        ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BestPrimary.rtf", _
        Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BestSecondary.rtf", _
        Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BOpen.rtf", Range:= _
        "", ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BU8.rtf", Range:="", _
         ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BU10.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BU12.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BU14.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BU16.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_BU18.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GOpen.rtf", Range:= _
        "", ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GU8.rtf", Range:="", _
         ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GU10.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GU12.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GU14.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GU16.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:="RankAndMedalStandings_GU18.rtf", Range:="" _
        , ConfirmConversions:=False, Link:=False, Attachment:=False
    Selection.InsertFile FileName:= _
        "RankAndMedalStandings_SpecialPrimaryU14.rtf", Range:="", _
        ConfirmConversions:=False, Link:=False, Attachment:=False
End Sub

Any suggestions on how to improve the code and/or macro will be truly appreciated.

Thanks a lot.

 

[kjv1611]

The only thing I'd suggest initially is that you could make your code shorter and more dynamic, so that if a file naming scheme changes, you don't have to change it in code.

You could use a table which stores the file paths and names for which you are using, and then refer to that via a recordset for spitting out the reports, and then combining them... all from the same table and recordset.

--

"If to err is human, then I must be some kind of human!" -Me

 

[MajP]

I am not very good at Word programming, but here is my solution.

make a module called filePicker. This opens a Pick File dialog box

Option Explicit

'This code was originally written by Ken Getz.
'It is not to be altered or distributed,
'except as part of an application.
'You are free to use it in any application,
'provided the copyright notice is left unchanged.
'
' Code courtesy of:
'   Microsoft Access 95 How-To
' Ken Getz and Paul Litwin
' Waite Group Press, 1996

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 Integer
    nFileExtension As Integer
    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
' You won't use these.
'Global Const ahtOFN_ENABLEHOOK = &H20
'Global Const ahtOFN_ENABLETEMPLATE = &H40
'Global Const ahtOFN_ENABLETEMPLATEHANDLE = &H80
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
' New for Windows 95
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
' Here's an example that gets an Access database name.
Dim strFilter As String
Dim lngFlags As Long
Dim varFileName As Variant
' Specify that the chosen file must already exist,
' don't change directories when you're done
' Also, don't bother displaying
' the read-only box. It'll only confuse people.
    lngFlags = ahtOFN_FILEMUSTEXIST Or _
                ahtOFN_HIDEREADONLY Or ahtOFN_NOCHANGEDIR
    If IsMissing(varDirectory) Then
        varDirectory = ""
    End If
    If IsMissing(varTitleForDialog) Then
        varTitleForDialog = ""
    End If

    ' Define the filter string and allocate space in the "c"
    ' string Duplicate this line with changes as necessary for
    ' more file templates.
    strFilter = ahtAddFilterItem(strFilter, _
                "Access (*.mdb)", "*.MDB;*.MDA")
    ' Now actually call to get the file name.
    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
' This is the entry point you'll use to call the common
' file open/save dialog. The parameters are listed
' below, and all are optional.
'
' In:
' Flags: one or more of the ahtOFN_* constants, OR'd together.
' InitialDir: the directory in which to first look
' Filter: a set of file filters, set up by calling
' AddFilterItem. See examples.
' FilterIndex: 1-based integer indicating which filter
' set to use, by default (1 if unspecified)
' DefaultExt: Extension to use if the user doesn't enter one.
' Only useful on file saves.
' FileName: Default value for the file name text box.
' DialogTitle: Title for the dialog.
' hWnd: parent window handle
' OpenFile: Boolean(True=Open File/False=Save As)
' Out:
' Return Value: Either Null or the selected filename
Dim OFN As tagOPENFILENAME
Dim strFileName As String
Dim strFileTitle As String
Dim fResult As Boolean
    ' Give the dialog a caption title.
    If IsMissing(InitialDir) Then InitialDir = CurDir
    If IsMissing(filter) Then filter = ""
    If IsMissing(FilterIndex) Then FilterIndex = 1
    If IsMissing(Flags) Then Flags = 0&
    If IsMissing(DefaultExt) Then DefaultExt = ""
    If IsMissing(FileName) Then FileName = ""
    If IsMissing(DialogTitle) Then DialogTitle = ""
    'If IsMissing(hwnd) Then hwnd = Application.wor
    If IsMissing(OpenFile) Then OpenFile = True
    ' Allocate string space for the returned strings.
    strFileName = Left(FileName & String(256, 0), 256)
    strFileTitle = String(256, 0)
    ' Set up the data structure before you call the function
    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
        ' Didn't think most people would want to deal with
        ' these options.
        .hInstance = 0
        '.strCustomFilter = ""
        '.nMaxCustFilter = 0
        .lpfnHook = 0
        'New for NT 4.0
        .strCustomFilter = String(255, 0)
        .nMaxCustFilter = 255
    End With
    ' This will pass the desired data structure to the
    ' Windows API, which will in turn it uses to display
    ' the Open/Save As Dialog.
    If OpenFile Then
        fResult = aht_apiGetOpenFileName(OFN)
    Else
        fResult = aht_apiGetSaveFileName(OFN)
    End If

    ' The function call filled in the strFileTitle member
    ' of the structure. You'll have to write special code
    ' to retrieve that if you're interested.
    If fResult Then
        ' You might care to check the Flags member of the
        ' structure to get information about the chosen file.
        ' In this example, if you bothered to pass in a
        ' value for Flags, we'll fill it in with the outgoing
        ' Flags value.
        If Not IsMissing(Flags) Then Flags = OFN.Flags
        ahtCommonFileOpenSave = TrimNull(OFN.strFile)
    Else
        ahtCommonFileOpenSave = vbNullString
    End If
End Function

Function ahtAddFilterItem(strFilter As String, _
    strDescription As String, Optional varItem As Variant) As String
' Tack a new chunk onto the file filter.
' That is, take the old value, stick onto it the description,
' (like "Databases"), a null character, the skeleton
' (like "*.mdb;*.mda") and a final null character.

    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 Integer
    intPos = InStr(strItem, vbNullChar)
    If intPos > 0 Then
        TrimNull = Left(strItem, intPos - 1)
    Else
        TrimNull = strItem
    End If
End Function

Public Function fGetFileName()
    Dim strFilter As String
    Dim lngFlags As Long
    strFilter = ahtAddFilterItem(strFilter, "Word Docs (*.Doc)", "*.Doc")
    strFilter = ahtAddFilterItem(strFilter, "RTF (*.rtf)", "*.rtf")
    strFilter = ahtAddFilterItem(strFilter, "Word 2007 Docs (*.Docx)", "*.Docx")
    fGetFileName = ahtCommonFileOpenSave(InitialDir:="C:\", filter:=strFilter, FilterIndex:=1, _
    Flags:=lngFlags, DialogTitle:="Select File Location")
    ' Since you passed in a variable for lngFlags,
    ' the function places the output flags value in the variable.
    Debug.Print Hex(lngFlags)
    Debug.Print fGetFileName
End Function

Build another module for your merge utilities

Public Sub findReports(ParamArray allDocs() As Variant)
    Dim varDoc As Variant
    Dim myFolder As String
    Dim myDocPath As String
    Dim blnValid As Boolean
    Dim blnExit As Boolean
    
    Dim msgResponse As String
    myFolder = CurDir
    For Each varDoc In allDocs
       
       Do Until blnValid Or blnExit
         myDocPath = myFolder & "\" & varDoc
         blnValid = CheckPath(myDocPath)
         If Not blnValid Then
           msgResponse = MsgBox("File " & varDoc & " not in directory: " & myFolder & ".  Do you want to choose directory?", vbYesNo)
           If msgResponse = vbNo Then
             blnExit = True
           Else
             myDocPath = fGetFileName
             myFolder = getFolderFromPath(myDocPath)
            If myDocPath = vbNullString Then
               MsgBox "No path Selected"
            Else
               MsgBox "Selected Folder: " & myFolder & vbCrLf & "Selected Path: " & myDocPath
               ChDir (myFolder)
               blnValid = True
            End If
          End If
        End If
        If blnValid Then
          Selection.InsertFile FileName:=myDocPath, Range:="", _
          ConfirmConversions:=False, Link:=False, Attachment:=False
        End If
       Loop
       blnValid = False
       blnExit = False
    Next varDoc
End Sub

Public Function getFolderFromPath(docPath As String) As String
  Dim slashLocation As Variant
  slashLocation = InStrRev(docPath, "\")
  getFolderFromPath = Left(docPath, slashLocation - 1)
End Function

Private Function CheckPath(strPath As String) As Boolean
  If Dir$(strPath) <> "" Then
    CheckPath = True
  Else
   CheckPath = False
  End If
End Function

call the above Procedure like this

Sub insertReports()
   findReports "Doc1.doc", "Doc2.Doc", "Doc3.doc"
End Sub

How this works. You pass in a list of all the document to merge. It checks the current directory for these documents and starts to merge them. If it can not find a document it prompts you for the location of the document. If the documents are in the new location it uses that location.

You could actually have documents in multiple locations.

 

[MajP]

http://www.4shared.com/file/117048660/a870df58/MergrWord.html

here is the code.

 

[titanl]

Hi kjv1611 and MajP,
Thanks so much for the replies. The table suggestion by kjv1611 seems very interesting but I have never try it before so I'm kind of don't know how to launch into that - will try in the future though.

I will try to use the code for the merge utilities as proposed by MajP. By the way, thanks so much for the module and code MajP. It was so kind of you to include them. They will definitely be of value in the future. I will give you a star for this.

Just to share something which I hope anyone of you or others could comment on.

Yesterday,after kjv1611 suggestions re the table, I tried to use and an unbound report whcih I named "RankAndMedalStandings_All" and then include all the 18 reports as subreport and inserting page break after each subreport. With this solution I am able to send the reports to Word application as one file thus solving the need to write more code to merge in word.

So what do you think of this subreports solution? Are there any pitfalls waitng around the corner?

Would really like to know your thoughts.

Thanks. Have a nice day.