Code:
Sub Export_Competency(Competency_Code As String, Competency_Instance As Integer, wrdApp As Word.Application)
Dim CurrentProcedure As String
Dim db As Database, rst As Recordset
Dim SQL As String
Dim InstanceWhere As String
Dim TranslationNumber As Long
Dim ExportFileName As String
Dim TemplateFileName As String
Dim ItemCount As Integer
Dim CompetencyType As Integer
Dim wrdDoc As Word.Document
Dim Item_ID As String
Dim File_Prefix As String
CurrentProcedure = "Export_Competency"
On Error GoTo Proc_Error
'
' Determine the competency type
' Competency type 2, National Qualification, has few items associated with it
'
CompetencyType = DLookup("CmptcyCat_CDE", "Competency", "Cmptcy_Code_ID = '" & Competency_Code & "'")
If CompetencyType = 1 Then File_Prefix = "SS"
If CompetencyType = 2 Then File_Prefix = "RQ"
If CompetencyType = 3 Then File_Prefix = "EQ"
If CompetencyType = 4 Then File_Prefix = "PG"
'
' Generate Template and output file names
'
TemplateFileName = DLookup("DocumentTemplates", "Control")
TemplateFileName = TemplateFileName & "\" & "OSS_Translation_Request_Template.doc"
ExportFileName = DLookup("ExportTranslationPath", "Control")
ExportFileName = ExportFileName & "\" & File_Prefix & "_Translation_" & Competency_Code & "_" & Format(Date, "dd-MMM-yyyy")
'
' open the template file
'
Set wrdDoc = wrdApp.Documents.Open(TemplateFileName, , , , , , , , , , , False)
Set db = CurrentDb
InstanceWhere = "[cmptcyinst_ID] = " & Competency_Instance
'
' Description
'
Set rst = db.OpenRecordset("Translate competency description") ' There is only one record in this recordset
wrdDoc.Bookmarks("OSS_code").Range.InsertAfter Competency_Code
wrdDoc.Bookmarks("OSS_name").Range.InsertAfter rst!Cmptcy_Name_En
wrdDoc.Bookmarks("file_date").Range.InsertAfter Format(Date, "dd-MMM-YYYY")
wrdDoc.Bookmarks("file_name").Range.InsertAfter ExportFileName
wrdDoc.Bookmarks("Instance_ID").Range.InsertAfter Competency_Instance
wrdDoc.Bookmarks("Instance_Type").Range.InsertAfter " 2 (Competency)"
wrdDoc.Bookmarks("Full_Listing").Range.InsertAfter "No"
wrdDoc.Bookmarks("Status_Code").Range.InsertAfter "5"
wrdDoc.Bookmarks("Status_Text").Range.InsertAfter "Approved"
ItemCount = 0
'
' T/S/K Statements
'
Set rst = db.OpenRecordset("Select * from [Translate Competency Statement] order by Statcat_Cde, Stat_SEQ")
While Not rst.BOF And Not rst.EOF
If rst!Stat_Text_SREM_Lang_IND = 1 Then
'
' Write_Item adds rows to the table - see below
'
Write_Item wrdApp, wrdDoc, ItemCount, TranslationNumber, rst!Stat_Text_SREM_En, _
IIf(ExportFrench, Nz(rst!Stat_Text_SREM_Fr, " "), " "), Item_ID
End If
rst.MoveNext
Wend
rst.Close
'
' Save the word document
'
wrdDoc.SaveAs (ExportFileName)
MsgBox Competency_Code & " translation document saved as " & vbCrLf & ExportFileName
Else
MsgBox "Competency Code " & Competency_Code & " had no items requiring translation. The status has been set to 'translated', and the translation file has been discarded", vbInformation, "Nothing to translate"
wrdDoc.Close wdDoNotSaveChanges ' Don't save changes to the template file
Set wrdDoc = Nothing
Set db = Nothing
Exit Sub
Proc_Error:
Process_Error CurrentForm, CurrentProcedure, Err.Description
wrdDoc.Close wdDoNotSaveChanges
End Sub
Sub Write_Item(wrdApp As Word.Application, wrdDoc As Word.Document, ItemCount As Integer, TranslationItem As Long, _
English As String, ExistingFrench As String, Optional Item_ID As String = "?")
Dim CurrentProcedure As String
Dim wrdRange As Word.Range
Dim Currentrow As Integer
On Error GoTo Proc_Error
CurrentProcedure = "Write_Item"
ItemCount = ItemCount + 1
If ItemCount = 1 Then
'
' Go to the item bookmark, and update that row
'
Set wrdRange = wrdDoc.GoTo(What:=wdGoToBookmark, Name:="Item")
wrdRange.Select
wrdRange.InsertAfter TranslationItem
'
' Move to the next cell to the right, for English
'
wrdApp.Selection.Move wdCell, 1
wrdApp.Selection.InsertAfter English
'
' Move to the next cell to the right, for French
'
wrdApp.Selection.Move wdCell, 1
wrdApp.Selection.InsertAfter ExistingFrench
'
' Move to the next cell to the right, for Item_ID
'
wrdApp.Selection.Move wdCell, 1
wrdApp.Selection.InsertAfter Item_ID
Else
'
' Insert a new row
'
Currentrow = wrdApp.Selection.Information(wdStartOfRangeRowNumber)
wrdDoc.Tables(1).Rows(Currentrow).Select
wrdApp.Selection.InsertRowsBelow 1
'
' when a row is added, the whole (new) row is selected
' Collapse de-selects the row, leaving the insertion point in the next cell
'
wrdApp.Selection.Collapse
wrdApp.Selection.InsertAfter TranslationItem
wrdApp.Selection.Move wdCell, 1
wrdApp.Selection.InsertAfter English
wrdApp.Selection.Move wdCell, 1
wrdApp.Selection.InsertAfter ExistingFrench
wrdApp.Selection.Move wdCell, 1
wrdApp.Selection.InsertAfter Item_ID
End If
Exit Sub
Proc_Error:
Process_Error CurrentForm, CurrentProcedure, Err.Description
End Sub
Inserting records into MSWord table
Windows 7 64bit 
Access 2010 64bit
Reply With Quote
