VBA: filling Word form fields and file management (1 Viewer)

[MikeLeBen]

Hello all,

I've set up a routine that fills out several different .docx word documents from an access console, based on the answers of .accde questionnaires.

It all works except for the part where I have an On Error GoTo statement that I prefer to keep commented so to make sure everything runs smooth.
Of course, this means I have to start manually an instance of Word before running the routine or else it gives an error.

Additionally, every time a Word form is filled out, the routine saves it and then copies it in another folder using the .CopyFile method of a Scripting.FileSystemObject.
I tried introducing a check on the existance of such folder (the function works ok when used elsewhere) but it does give another error in this instance.

Private Sub cmdFillOutForm_Click()

Dim appWord     As Word.Application '
Dim doc         As Word.Document    '
'''''''''''''''''''''''''''''''''''''
Dim db          As DAO.Database     '
Dim rs          As DAO.Recordset    '
'''''''''''''''''''''''''''''''''''''
Dim strsql      As String  'esegue la ricerca della risposta
Dim strsqlchk   As String  'esegue la ricerca nella tabella tblrispcheck
Dim strsqlmemo  As String  'esegue la ricerca nella tabella tblrispmemo
Dim risp        As String  'la risposta restituita da SQL
''''''''''''''''''''''''''''
Dim formPath    As String  'percorso modulo word da riempire
Dim strFolder   As String  'percorso cartella questionari compilati
Dim strFile     As String  'percorso singolo questionario
''''''''''''''''''''''''''''
Dim i_dom       As Integer

MsgBox "Selezionare la cartella che contiene i questionari compilati.", vbInformation, "Informazione"

'''''''''''''''''''''''''''''''''''''''''
' inizializzazione variabili e stringhe '
'''''''''''''''''''''''''''''''''''''''''

strFolder = GetFolder(Environ$("USERPROFILE"))
formPath = "C:\Documents and Settings\msorrentino\Documenti\Questionario_per_stampa.docx"
strsql = "SELECT Risposta FROM tblRisposte WHERE IDDom = "
strsqlchk = "SELECT IDCheck FROM tblRispcheck WHERE CheckRisp = True AND IDDom = "
strsqlmemo = "SELECT Risposta FROM tblRispmemo WHERE IDDom = "
i_dom = 1

'Avoid error 429, when Word isn't open.
'On Error Resume Next
'Err.Clear 'commented to check on result - implies I manually open word

'Set appWord object variable to running instance of Word.
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
    'If Word isn't open, create a new instance of Word.
    Set appWord = New Word.Application
End If

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
strFile = Dir$(strFolder & "*.accde")

Do While Len(strFile) > 0
    Set db = OpenDatabase(strFile)
    Set rs = db.OpenRecordset(strsql & i_dom & ";")
    Set doc = appWord.Documents.Open(formPath, , False)
        
    With doc
        .ResetFormFields
        .FormFields("Prefilledhome").Result = "LUISS Guido Carli"
        .FormFields("Prefilledcode").Result = "I ROMA03"
        .FormFields("Prefilledcountry").Result = "Italia"
    End With
            
    For i_dom = 1 To 74
    
    Select Case i_dom
    'loads of fields being filled out (I cut this part for readability's sake)        
    End Select
    
    Next i_dom
    
    doc.Save
    Call saveDoc(formPath, strFolder, strFile)
    
    db.Close
    Set db = Nothing
    Set rs = Nothing
    
    strFile = Dir$()
Loop

doc.Close
appWord.Quit

Set doc = Nothing
Set appWord = Nothing

End Sub

and the other routine:

Public Sub saveDoc(formPath As String, strFolder As String, fName As String)

Dim fs      As Object
Dim fFolder As String 'final folder to save in

fName = Replace(fName, ".accde", ".docx")
fFolder = strFolder & "\WordCompilati\"

Set fs = CreateObject("Scripting.FileSystemObject")
'If FileFolderExists(fFolder) Then
'    'MkDir fFolder
'Else
'    MkDir fFolder
'End If

fs.CopyFile formPath, fFolder & fName
Set fs = Nothing

End Sub

 

[MikeLeBen]

I fixed it, just needed some intensive debugging.

Can post clean code if anyone needs to perform the same task, just reply to this thread.

 

[vbaInet]

It would be great if you could post your solution in case someone comes across your thread.

 

[MikeLeBen]

Ok, here goes.

Private Sub cmdFillOutForm_Click()

Dim appWord     As Word.Application '
Dim doc         As Word.Document    '
'''''''''''''''''''''''''''''''''''''
Dim db          As DAO.Database     '
Dim rs          As DAO.Recordset    '
'''''''''''''''''''''''''''''''''''''
Dim strsql      As String  'looksup the answer in your table
Dim strsqlchk   As String  'i needed this cause i had different tables for
Dim strsqlmemo  As String  'different types of answers
Dim risp        As String  'this is for clearness' sake
''''''''''''''''''''''''''''
Dim formPath    As String  'path to your Word form
Dim strFolder   As String  'path to save your filled out access questionnaires
Dim strFile     As String  'needed for the Dir$() function
''''''''''''''''''''''''''''
Dim i_dom       As Integer 'counter for questions
Dim num_q       As Integer 'counter for questionnaires

MsgBox "Please select the folder that contains filled out access questionnaires.", vbInformation, "Informazione"

'''''''''''''''''''''''''''''''''''''''''
' inizializzazione variabili e stringhe '
'''''''''''''''''''''''''''''''''''''''''
strFolder = GetFolder(Environ$("USERPROFILE"))
formPath = "C:\PathTo\YourWordForm.docx"
strsql = "SELECT Answer FROM tblRisposte WHERE IDAns = "
strsqlchk = "SELECT IDCheck FROM tblRispcheck WHERE CheckRisp = True AND IDAns = "
strsqlmemo = "SELECT Answer FROM tblRispmemo WHERE IDAns = "

On Error GoTo errHandler

If Right(strFolder, 1) <> "\" Then strFolder = strFolder & "\"
If Len(strFolder) = 1 Then Exit Sub

Set appWord = CreateObject("Word.Application")
Set doc = appWord.Documents.Open(formPath, , False)
appWord.Application.Visible = False

strFile = Dir$(strFolder & "*.accde") 'or whatever extension you need

Do While Len(strFile) > 0
    Set db = OpenDatabase(strFile)
    Set rs = db.OpenRecordset(strsql & i_dom & ";")
    
    DoEvents
        DoCmd.OpenForm "frmStatusBar", acNormal, , , , acHidden 'progress bar
    
    With doc
        .ResetFormFields
        .FormFields("Prefilledhome").Result = "LUISS Guido Carli"
        .FormFields("Prefilledcode").Result = "I ROMA03"
        .FormFields("Prefilledcountry").Result = "Italia"
    End With
            
    For i_dom = 1 To 74
    
	'do stuff for each question in the questionnaire
	'such as Set rs = db.OpenRecordset(strsql & i_dom & ";")
    '        If Not rs.EOF Then
    '           rs.MoveFirst
    '           risp = rs.Fields(0) 'risp string is just for clearness - you can use the fields property directly
	'           doc.formfields("QSTN" & i_dom).result = risp
	
    Next i_dom
    
    doc.Save
    Call saveDoc(formPath, strFolder, strFile)
    
    db.Close
    
    strFile = Dir$()
    num_q = num_q + 1
Loop

doc.Close
appWord.Application.Quit

DoCmd.Close acForm, "frmStatusBar"

If num_q <> 1 Then
    MsgBox num_q & " questionnaires filled out.", vbInformation, "Result"
Else
    MsgBox "One questionnaire filled out.", vbInformation, "Result"
End If

Exit Sub

errHandler:
    MsgBox "Error " & Err.Number & " - " & Err.Description, vbCritical

End Sub

 

[vbaInet]

Thanks for posting.