HERRICK BROWN & Company Ltd.
If you need an expert witness for a matter involving Access or Word, please contact us.
Prepared by George Herrick, Herrick Brown & Company Ltd,
PO Box 21, Eccles, Manchester. M30 7BN.
mail<at>herrick-brown.co.uk where <at> = @
'An Access 2000 module - Function
'Outputs several Rich Text Format and Word 2000 format documents, and an Excel spreadsheet.
'Whilst Word will open RTF files, there are differences, which can be important.
'Runs after a MakeTable Query, using the Table.
'Runs before an Update Query.
'Uses a Form and a Report.
'Is Run from the AUTOEXEC macro.
Function DoOutPutToWord()
Dim WdApp As Word.Application
Dim docone As Word.Document
' For use by Word. As a process, not an application with a user interface.
Dim db As Database
Dim rstTemp As Recordset
Dim MyForm As Form
Dim MyControl As Control
' For use by Access.
Dim lid As Double 'Letter ID
Dim lenlid As String
Dim hno As String 'Hospital Number
Dim lenhno As Integer
Dim uno As Integer 'Unique Number
Dim unostr As String 'Unique Number as a String
Dim fname As String 'File Name
Dim letdate As Variant 'Letter Date
Dim ldatestr As String
Dim repname As String 'Report Name
Dim ghno As Boolean 'Good Hospital Number, judged by length
Dim timewaster As Integer
On Error GoTo errorhandler
ghno = True
uno = 0
repname = "1-A_SINGLE_LETTER"
Set db = CurrentDb 'The module is using data from the tables in this .MDB file.
DoCmd.OpenForm ("LIDForm") 'The Control on the Form holds the value
Set MyForm = Forms!LIDForm 'for the Criteria in the embedded query
Set MyControl = MyForm![Text0] 'that is the source of the data for the Report.
Set rstTemp = db.OpenRecordset("Temp") 'This is a Table with the list of "Letters" to process now.
Set WdApp = New Word.Application 'This invokes Word, without the user interface.
If rstTemp.RecordCount > 0 Then 'If there are records to work with
Do Until rstTemp.EOF
hno = rstTemp![Hospital_Number] 'Get the data
lenhno = Len(hno) ' and sort it to required format.
lid = rstTemp![Letter_ID] 'This should be unique for the letters
unostr = Right$(lid, 4) 'in a batch.
MyControl = lid 'Put value in to Control on Form.
letdate = rstTemp![Letter_Date] 'The date of the letter is used in the filenames.
ldatestr = Format(letdate, "yyyymmdd")
Select Case lenhno
Case 4
hno = "0000" & hno
ghno = True
Case 5
hno = "000" & hno
ghno = True
Case 6
hno = "00" & hno
ghno = True
Case 7
hno = "0" & hno
ghno = True
Case 8
hno = "" & hno
ghno = True
Case Else
ghno = False
End Select
' If the Hospital Number had fewer than 4 numbers it could not be correct.
If ghno Then
'The combination of the Letter Date and the rightmost 4 characters of the
'Letter ID is unique for a letter ; but will be the same each time a letter
'is processed by this module ; but each Letter should only be processed once.
fname = "e:\clads\" & hno & "A0999" & ldatestr & unostr & ".rtf"
'This OutputTo produces a .RTF file, the False means that Word does not start.
DoCmd.OutputTo acOutputReport, repname, acFormatRTF, fname, False
'Then open the .RTF in Word - but not on screen.
Set docone = Documents.Open(fname)
'Change the file name
fname = "e:\clads\" & hno & "A0999" & ldatestr & unostr & ".doc"
With docone
'Save As Word Format and Close
ActiveDocument.SaveAs FileName:=fname, fileformat:=wdFormatDocument,lockcomments:=False,Password:="",
addtorecentfiles:=False, savenativepictureformat:=False, SaveFormsData:=False,
saveasaoceletter:=False
ActiveDocument.Close
End With
rstTemp.Edit 'Get the Record ready for alteration.
rstTemp![ToEPRDate] = Now 'Marking this Letter as having been processed.
rstTemp.Update 'Make change
rstTemp.MoveNext 'Go to next.
uno = uno + 1
Else
rstTemp.Edit
rstTemp![ToEPRDate] = #1/1/1901# 'And so this Letter will be missed.
rstTemp.Update
rstTemp.MoveNext
uno = uno + 1
End If
Loop
End If
rstTemp.Close 'Finish with the Table
' This makes an Excel spreadsheet of the list of Letter that have been processed.
fname = "RheumToEpr" & Format(Now(), "Long Date") & uno & ".xls"
DoCmd.OutputTo acOutputTable, "Temp", acFormatXLS, "e:\clads\" & fname, False
Set db = Nothing 'Drop the database
WdApp.Quit 'Stop the WinWord process
Exit Function
errorhandler:
rstTemp.Close
fname = "RheumToEprERROR" & uno & ".xls"
DoCmd.OutputTo acOutputTable, "Temp", acFormatXLS, "e:\clads\" & fname, False
Set db = Nothing
WdApp.Quit
MsgBox "Rheum to EPT Access .MDB Module Error Number " & Err
End Function
'Prepared by George Herrick, Herrick Brown & Company Ltd,
'PO Box 21, Eccles, Manchester. M30 7BN.
'for Hope Hospital, M6 8HD.
'All rights reserved. Both parties have intellectual property rights in this software
'and have not given any permissions to other parties.
If you would like to use this module, e-mail us and we will help.
mail<at>herrick-brown.co.uk where <at> = @