Display the answer of each question in word document from Access form

refID is in the following format:

1.1
1.2
1.3
1.4
2.1
2.2
 
Hi Static, any help on this please? Thanks
 
Please upload a copy of your database.
 
Please see attached.

The query qryQAMatrix is as below:
Code: 
 SELECT tblQAMatrix.RefID, tblQAMatrix.StandardDoc, tblQAStandard.Score, tblQAStandard.QAID
FROM tblQAMatrix INNER JOIN tblQAStandard ON tblQAMatrix.ID = tblQAStandard.StandardID;
 

Attachments

Static, is there any way to keep the word document as attached . And just add the scoring in the next blank column ??
 

Attachments

Static, any help on this please? Many Thanks
 
Your original template had 3 columns. The code I gave you had one and in post #9 you asked for three columns, which means that either
1) you know enough about VBA to understand the code or
2) you ran it successfully.

I'm guessing option 1 is out so that leaves option 2, and since a one column format is what you now want I don't know what else you need.
 
Static, there was some formatting issues when the data gets copied across word document. Doesn't look like the actual word template as attached.
So I am just looking for another alternative so that the template remains same with everything (all the formatting etc..) and just copy the Scoring across the word doc for all the records. Please see below the code as well but the score doesn't get displayed for the records with this code:
Code: 
 Private Sub cmdSummit_Click()
Dim db As DAO.Database
'define query object perameter
Dim qry As DAO.QueryDef
Dim i As Integer
Dim rsMailmerge As Recordset
Dim strTextFile As String
Dim strTemplatePath As String
Dim strSavePath As String
Dim strSaveName As String
 Me.txtHidden.SetFocus
 strTemplatePath = "L:\Access Databases\Group Manufacturing\Mortgages Direct\Academy\ADFE\Files\T&C Templates\QA Forms\"
strSavePath = DLookup("Variable", "tblVariable", "VariableID=16")
strSaveName = "Health Check Form " & Format(Now(), "yyyymmmdd_hhmmss") & " " & Me.cboAgent.Column(1) & ".doc"
 'set current datedate as database objects
Set db = CurrentDb
'set your record set using reference from the form
Set rsMailmerge = db.OpenRecordset("SELECT * FROM tblQA WHERE [QAID] =" & Me.QAID)
 'Call GetWordHandle
'function that opens word to run in the background, function can be placed in a global module
   
    If WordApp Is Nothing Then ' if word not called before
        Err.clear   ' Clear Err object in case error occurred.
        Set WordApp = CreateObject("Word.Application")   'Start a new word application
    Else
        ' an instance of word has been created before
        On Error Resume Next 'Turn off error handling
        Err.clear   ' Clear Err object in case error occurred.
        WordApp.Visible = False 'attempt to access previous instance of word
        If Err.Number <> 0 Then ' if instance of word no longer exists then create a new one
            Err.clear   ' Clear Err object
            Set WordApp = CreateObject("Word.Application")   'Start a new word application
            On Error GoTo 0 'Revert to normal error  handling
        End If
    End If
    'Hide word (it will be made visible again CloseOrEditDocument or if an error occurs)
   
    WordApp.Visible = False
    WordApp.WindowState = 2
    WordApp.Visible = False
 'next we are going to create a text file that that the word template will merge with
'_________________________________________________________________________________________
 'text file file name
strTextFile = "HealthCheck_" & Format(Now(), "yyyymmdd_hhnnss")
 'function that creates and saves the text file
createKFIMailMergefile strPath, strTextFile & ".txt"
 'open template
Set WordDoc = WordApp.Documents.Open(strTemplatePath & "Health Check Form.dot")
'merge template with txt file
WordDoc.MailMerge.MainDocumentType = 0
WordDoc.MailMerge.Destination = wdSendToNewDocument
WordDoc.MailMerge.OpenDataSource (strPath & strTextFile & ".txt")
WordDoc.MailMerge.Execute
 'Go through all created doc and remove all mail merge errors
For i = 1 To WordApp.Application.Documents.Count
    If InStr(1, WordApp.Application.Documents(i).Name, "Error") <> 0 Then
        WordApp.Application.Documents.Item(i).Close False
        i = i - 1
    End If
    If i = WordApp.Application.Documents.Count Then Exit For
Next i
 'Save merged document as new file
WordApp.ActiveDocument.AttachedTemplate.Saved = True
WordDoc.Application.Documents.Item(1).SaveAs strSavePath & strSaveName, , , , False, , True
 'Go through all created doc and close them
    For i = 1 To WordApp.Application.Documents.Count
        WordApp.Application.Documents.Item(WordApp.Application.Documents.Count).Close False
    Next i
 'WordDoc.Close
'WordApp.Quit
 'delete the text file
Kill strPath & strTextFile & ".txt"
 'delete the subs
exithere:
WordApp.Quit
Set WordDoc = Nothing
Set WordApp = Nothing
Set qry = Nothing
Set db = Nothing
MsgBox ("Export Completed")
'MergePCACallData
Application.FollowHyperlink strSavePath & strSaveName
Exit Sub
 exporterror:
Resume exithere
End Sub
Code: 
 Function createKFIMailMergefile(sFileDIR As String, sFileName As String)
'static constants that make the fumction work
Dim FileNumber
Dim rs As Recordset
Dim headers As String
Dim record As String
Dim i As Integer
 'variable function that change depending on the data that is being added to the text file
Dim sScore1 As String
Dim sScore2 As String
Dim sScore3 As String
Dim sScore4 As String
Dim sScore5 As String
Dim sScore6 As String
Dim sScore7 As String
Dim sScore8 As String
Dim sScore9 As String
Dim sScore10 As String
Dim sScore11 As String
Dim sScore12 As String
Dim sScore13 As String
Dim sScore14 As String
Dim sScore15 As String
Dim sScore16 As String
Dim sScore17 As String
Dim sScore18 As String
Dim sScore19 As String
Dim sScore20 As String
Dim sScore21 As String
Dim sScore22 As String
Dim sScore23 As String
'set the variables that will be used for this recordset as null
 sScore1 = ""
sScore2 = ""
sScore3 = ""
sScore4 = ""
sScore5 = ""
sScore6 = ""
sScore7 = ""
sScore8 = ""
sScore9 = ""
sScore10 = ""
sScore11 = ""
sScore12 = ""
sScore13 = ""
sScore14 = ""
sScore15 = ""
sScore16 = ""
sScore17 = ""
sScore18 = ""
sScore19 = ""
sScore20 = ""
sScore21 = ""
sScore22 = ""
sScore23 = ""
 
'Get unused file (note by SW - unsure what this does)
FileNumber = FreeFile
        
    i = 1
    'First we open a need to create the headings. (opens the file and sets the output for the data to be transfered into it)
    Open sFileDIR & sFileName For Output As #FileNumber ' Create filename.
    
    'Get all QA Data
    'Open the recordset for where this particular data will be sourced from (can be table or a query)
    'Set rs = CurrentDb.OpenRecordset("SELECT * FROM tblQAStandard WHERE QAID=" & Me.txtQAID)
        
    'loop through all the records, setting format where necessary and dealing with null values
    With CurrentDb.OpenRecordset("SELECT * FROM tblQAStandard WHERE QAID=" & Me.txtQAID)
    If Not .BOF And Not .EOF Then
        .MoveFirst
        Do While Not .EOF
             headers = headers & """" & "Score" & i & """" & vbTab
             record = record & """" & RemoveTrailingvalue(!Score) & """" & vbTab
             i = i + 1
            .MoveNext
        Loop
    End If
        .Close
    End With
      
    Print #FileNumber, headers ' Output text.
    Print #FileNumber, record ' Output text.
        
    Close #FileNumber   ' Close file.
End Function
 

Attachments

Yes Aman and I are in the same team working on the same task but nobody is able to figure it out :(
 
Well, I don't see any of my code in there and you still haven't said what was wrong with it. :rolleyes:

Where did this mailmerge stuff come from? edit: never mind.

Maybe the problem isn't that this is a particularly difficult task, but that you don't take any notice of what people say and don't give proper feedback.

Getting help is a 2 way thing.

"some formatting issues" to me would mean, "fix the formatting issues", not "let's run around in circles looking for other code we don't understand."
 
Last edited:
Static, as discussed in the previous posts I am getting "Subscript out of range runtime error 9" in the code:
Code: 
 Do Until .EOF
            CurSec = Split(.Fields(0), ".")
             Set wr = wt.Rows.Add
            wr.Cells(1).Range.Text = CurSec(1) & "." & CurSec(2)
            wr.Cells(2).Range.Text = .Fields(1)
            wr.Cells(3).Range.Text = .Fields(2)
             
            If Not CurSec(0) = PrevSec Then
                'new section, create a header
                
                PrevSec = CurSec(0)
                Set wr = wt.Rows.Add(wr)
                wr.Cells(1).Range.Text = SecName(CurSec(0))
                wr.Cells(3).Range.Text = "Response"
                wd.Range(wr.Cells(1).Range.Start, wr.Cells(2).Range.End).Cells.Merge
                RowFormat wr.Range, True
            End If
            
            .MoveNext
        Loop
 
That's because the code expects the question ID to be in the format

1.1.1

But your format is

1.1

The first 1 signifies the category, and is used to look up the heading.

You should be able to create a query that puts the ID in the proper format.

Or you can upload a copy of your database, not a spreadsheet.
 
I am confused now. You show code from an other topic (the one were scores needs to be displayed in word) And here it is the answer of each question.

So what do you want here ? scores or answers ?
 
Static, I can't upload the database because of security restrictions so see attached the PDF format for the tables tblQAMatrix and tblQAStandard.

And also I do need headers for all the Records which are in "Headers" field because for each Form the header is different.

e.g for Health check Form , we have different headers .
For QAT Call Review Monitoring Form , we have different headers.

Thanks
 

Attachments

Static, sorry to bother you but I want some tweaks in the code.

The following code now works but doesn't display all the Headers.

The code displays RefID,Document name and Score . But I also want it to look for Header field in the Query and display appropriate headers for the records. The Header field stores the Header name and if it is same for 5 records then it will mean display 5 records under that header and then move to the next ones...
Code: 
 Private Sub cmdsummit_Click()
    Dim CurSec() As String, PrevSec As String
    
    With CurrentDb.OpenRecordset("select refid,standarddoc,score from qryQAMatrix where QAID=" & txtQAID & "")
       
        If .BOF And .EOF Then Exit Sub
         Dim wd As New Word.Document
        With wd.Parent
            .Visible = True
            .Activate
            .ScreenUpdating = False
        End With
        
        Dim wt As Word.Table, wr As Word.Row
        Set wt = wd.Tables.Add(wd.Parent.Selection.Range, 1, 3)
        wt.Columns(1).Width = 40
        wt.Columns(2).Width = 400
        wt.Columns(3).Width = 90
        
        RowFormat wt.Range, False
        
        Do Until .EOF
            CurSec = Split(.Fields(0), ".")
            'CurSec(0) = .Fields(0)
            Set wr = wt.Rows.Add
          '  wr.Cells(1).Range.Text = CurSec(1) & "." & CurSec(2)
            wr.Cells(1).Range.Text = .Fields(0)
            wr.Cells(2).Range.Text = .Fields(1)
            wr.Cells(3).Range.Text = .Fields(2)
             
            If Not CurSec(0) = PrevSec Then
                'new section, create a header
                
                PrevSec = CurSec(0)
                Set wr = wt.Rows.Add(wr)
                wr.Cells(1).Range.Text = SecName(CurSec(0))
                wr.Cells(3).Range.Text = "Response"
                wd.Range(wr.Cells(1).Range.Start, wr.Cells(2).Range.End).Cells.Merge
                RowFormat wr.Range, True
            End If
            
            .MoveNext
        Loop
        wt.Rows(1).Delete
    End With
    
    With wd.Parent
        .ScreenUpdating = True
    End With
        
    
End Sub
 Private Function SecName(id) As String
    Select Case id
    Case 1: SecName = "T&C File"
    Case 2: SecName = "Desk Desk"
    Case 3: SecName = "New Release"
    Case 4: SecName = "Call Audit"
    Case 5: SecName = "Ad hoc"
    End Select
End Function
 
Also please see attached the word doc , we need to adjust the table so some alignments needs to be made ..

Many thanks for your help so far. Please can you help me in displaying the headers and adjusting the alignments now. I am almost there so need your help badly.
 

Attachments

The table will be inserted wherever the bookmark is. Adjust the left column.
Not sure why you're using hidden text.

Give this a try

Code: 
 Private Sub cmdsummit_Click()
    Dim CurSec() As String, PrevSec As String
    
    With CurrentDb.OpenRecordset("select refid,standarddoc,score,header from qryQAMatrix where QAID=" & txtQAID & "")
       
        If .BOF And .EOF Then Exit Sub
         Dim wd As New Word.Document
        With wd.Parent
            .Visible = True
            .Activate
            .ScreenUpdating = False
        End With
        
        Dim wt As Word.Table, wr As Word.Row
        Set wt = wd.Tables.Add(wd.Parent.Selection.Range, 1, 3)
        wt.Columns(1).Width = 40
        wt.Columns(2).Width = 400
        wt.Columns(3).Width = 90
        
        RowFormat wt.Range, False
        
        Do Until .EOF
            CurSec = .fields("header") 'Split(.Fields(0), ".")
            'CurSec(0) = .Fields(0)
            Set wr = wt.Rows.Add
          '  wr.Cells(1).Range.Text = CurSec(1) & "." & CurSec(2)
            wr.Cells(1).Range.Text = .Fields("refid")
            wr.Cells(2).Range.Text = .Fields("standarddoc")
            wr.Cells(3).Range.Text = .Fields("score")
             
            If Not CurSec = PrevSec Then
                'new section, create a header
                
                PrevSec = CurSec 'CurSec(0)
                Set wr = wt.Rows.Add(wr)
                wr.Cells(1).Range.Text = CurSec 'SecName(CurSec(0))
                wr.Cells(3).Range.Text = "Response"
                wd.Range(wr.Cells(1).Range.Start, wr.Cells(2).Range.End).Cells.Merge
                RowFormat wr.Range, True
            End If
            
            .MoveNext
        Loop
        wt.Rows(1).Delete
    End With
    
    With wd.Parent
        .ScreenUpdating = True
    End With
    
End Sub
 
Static, As the code is on click event of a button. so when I click the button first then it gives me runtime error '462',The remote server machine doesn't exist or unavailable? When I press debug then it makes the following line highlighted:
Code: 
  r.Borders(i).LineStyle = Options.DefaultBorderLineStyle

but if I just close the word document and press the button again then it works fine.
 
Last edited:
And also please see attached the word document that gets opened when a button is clicked. There is a mail merge to retrieve the data from table tblQA but the fields don't get merged.
 

Attachments

You must log in or register to reply here.

Similar threads

C
download invoice documents from Amazon - possible?
Replies
7
Views
371
CJ_London
C
S
Solved Only the Document, not the Path
2
Replies
31
Views
763
Pat Hartman
P
G
How to display a Word document in Access
Replies
14
Views
1,487
Pat Hartman
P
C
Embedding a linked document in a report
Replies
7
Views
860
isladogs
isladogs
T
Table Displayed in Text Box?
Replies
7
Views
507
TheSearcher
T

Users who are viewing this thread

Total: 1 (members: 0, guests: 1)
Back
Top Bottom