| {\rtf1\ansi\ansicpg1252\deff0\deflang1044{\fonttbl{\f0\fnil\fcharset0 MS Sans Serif;}} \viewkind4\uc1\pard\f0\fs17 Creating a Word Mail merge document using a Record set \par The code will allow you to pass a template name and a recordset to ONE routine and this will then create a Word Mail Merge document based upon the selected template. If no template is found then a blank file is created \par \par _____________________ the class file: \par \par Option Explicit \par '****************************************************************** \par ' Name: cls_wrd_report_manager \par ' This Class object provides the rules needed to \par ' produce a word mail merge from by passing the \par ' template file and a valid recordset. \par '****************************************************************** \par ' Description: Alls a word mail merge document to be created from \par ' an ADO recordset and a template file. \par '****************************************************************** \par ' (c) Illuminaries Ltd 2002 . All rights \par ' reserved. \par '****************************************************************** \par ' Written By : Jonathan Adams (MCP) \par ' web address : www.illuminaries.co.uk \par '****************************************************************** \par ' Change the code as you please but please leave the \par ' copyright information \par '****************************************************************** \par ' implements the word routines class \par '****************************************************************** \par 'Usage :- \par ' \par 'Dim iobj_word as cls_wrd_report_manager \par ' \par ' Set iobj_word = New cls_wrd_report_manager \par ' \par ' rs_data =the recordset to output \par ' s_report_path :=Path and filename of template document \par ' b_Print := True or False (Print or Show) \par ' \par ' Call iobj_word.produce_mail_merge(rs_data, s_report_path, b_Print) \par '****************************************************************** \par Private obj_wrd_routines As i_word_routines \par Private Function pf_write_recordset_to_HTML(ByVal obj_recordset As ADODB.Recordset, ByRef s_header_record As String) As String \par 'on error resume next \par Dim rsField As ADODB.Field \par Dim s_output As String \par Dim s_ref As String \par ' convert the recordset information into an HTML Table \par pf_write_recordset_to_HTML = "" \par \par s_header_record = "" \par obj_recordset.MoveFirst \par \par s_output = s_output & "
\par ' return the HTML text to the caller \par pf_write_recordset_to_HTML = s_output \par End Function \par \par \par \par \par Public Function Get_Application_Pointer() As Object \par On Error GoTo get_word_application_pointer_errorhandler \par Dim wrd_app As Object \par Dim b_got_error As Boolean \par ' attempt to attached to an exsiting instance of word \par Set wrd_app = GetObject(, "Word.Application") \par \par If b_got_error Then \par ' if not create a new one. \par Set wrd_app = CreateObject("Word.Application") \par End If \par ' return the object reference \par Set Get_Application_Pointer = wrd_app \par \par \par get_word_application_pointer_exit: \par \par Exit Function \par get_word_application_pointer_errorhandler: \par b_got_error = True \par Resume Next \par \par Create_mailmerge_data_file_Exit: \par Exit Function \par Create_mailmerge_data_file_Errorhandler: \par Err.Raise Err.Number, "cls_wrd_report_manager.Get_Application_Pointer", Err.Description \par Resume \par Resume Create_mailmerge_data_file_Exit \par End Function \par \par \par Private Function pf_create_merge_data(ByVal rs_merge_data As ADODB.Recordset, ByRef s_header_record As String) As String \par '--------------------------------------------------------------------------- \par ' Routine will create the mail merge document data file from the \par ' passed recordset object and passback the filename to the \par ' calling function \par '--------------------------------------------------------------------------- \par On Error GoTo pf_create_merge_data_errorhandler \par Dim s_data_filename As String \par Dim s_HTML_String As String \par Dim l_filehandle As Long \par Dim obj_word As Word.Application \par Dim obj_document As Word.Document \par pf_create_merge_data = False \par s_data_filename = pf_get_tempory_filename() \par \par s_HTML_String = pf_write_recordset_to_HTML(rs_merge_data, s_header_record) \par \par If Dir(s_data_filename) <> "" Then \par Kill s_data_filename \par End If \par \par l_filehandle = FreeFile \par \par ' create the HTML file version \par Open s_data_filename For Output As #l_filehandle \par Print #l_filehandle, s_HTML_String \par Close #l_filehandle \par ' create new application object \par Set obj_word = Get_Application_Pointer \par ' retrieve a document pointer \par Set obj_document = obj_word.Documents.Add \par \par If Not obj_document Is Nothing Then \par If Dir(Left(s_data_filename, Len(s_data_filename) - 3) & "doc") <> "" Then \par Kill Left(s_data_filename, Len(s_data_filename) - 3) & "doc" \par End If \par ' open word \par 'obj_word.Application.Visible = True \par ' insert the HTML document into the word document \par obj_document.Range.InsertFile s_data_filename \par obj_document.SaveAs Left(s_data_filename, Len(s_data_filename) - 3) & "doc" \par obj_document.Close \par End If \par \par ' clear the word object reference \par Set obj_document = Nothing \par Set obj_word = Nothing \par \par pf_create_merge_data = Left(s_data_filename, Len(s_data_filename) - 3) & "doc" \par \par \par \par pf_create_merge_data_exit: \par \par Exit Function \par pf_create_merge_data_errorhandler: \par Err.Raise Err.Number, "cls_wrd_report_manager.pf_create_merge_data", Err.Source \par GoTo pf_create_merge_data_exit \par End Function \par \par Private Function pf_get_tempory_filename() As String \par On Error GoTo pf_get_tempory_filename_errorhandler \par Dim s_file_name As String \par \par pf_get_tempory_filename = "" \par ' call standard routine to return a file without \par ' header information \par s_file_name = get_tmp_file_name() \par \par If s_file_name <> "" Then \par ' add the relvant file extension to the dataflie \par s_file_name = s_file_name & ".htm" \par \par End If \par \par pf_get_tempory_filename = s_file_name \par \par pf_get_tempory_filename_exit: \par \par \par Exit Function \par pf_get_tempory_filename_errorhandler: \par Err.Raise Err.Number, "cls_wrd_report_manager.pf_get_tempory_filename", Err.Source \par GoTo pf_get_tempory_filename_exit \par End Function \par \par \par Public Function produce_mail_merge(ByVal rs_merge_recordset As ADODB.Recordset, ByVal s_word_template_file_name As String, ByVal b_Print As Boolean) As Boolean \par On Error GoTo produce_mail_merge_errorhandler \par Dim obj_app As Word.Application \par Dim wrd_doc As Word.Document \par Dim s_header_record As String \par Dim s_message As String \par Dim s_datafile As String \par ' create a new pointer to a the word document \par Set obj_app = Me.Get_Application_Pointer() \par \par \par \par ' firstly, create a data file to hold the \par ' mailmerge data. \par s_datafile = pf_create_merge_data(rs_merge_recordset, s_header_record) \par \par \par ' Check the required word template is present on the \par ' system. \par If Dir(s_word_template_file_name) <> "" Then \par ' Open the file to insert data \par Set wrd_doc = obj_app.Documents.Open(s_word_template_file_name) \par Else \par s_message = "Template : " & s_word_template_file_name & String(2, vbCrLf) & _ \par "The required word template file could not be found within your system. " & _ \par "Quest will now create a blank record with the mail merge data you require." \par MsgBox s_message, vbInformation \par Set wrd_doc = obj_app.Documents.Add \par End If \par ' Take a copy of the document \par ' save to a tempory file name \par wrd_doc.SaveAs Left(s_datafile, Len(s_datafile) - 4) & "_output.doc" \par \par ' bind the data to the document \par wrd_doc.MailMerge.OpenDataSource Name:=s_datafile \par \par If Not b_Print Then \par ' show the new word document \par obj_app.Visible = True \par Else \par 'TODO : Print the mail merge and close \par wrd_doc.MailMerge.Destination = 1 \par wrd_doc.MailMerge.Execute \par ' Close the word session down. \par wrd_doc.Close \par obj_app.Visible = False \par Set wrd_doc = Nothing \par Set obj_app = Nothing \par End If \par ' clear the word objects \par \par \par produce_mail_merge_exit: \par \par Exit Function \par produce_mail_merge_errorhandler: \par Err.Raise Err.Number, "cls_wrd_report_manager.produce_mail_merge", Err.Description \par Resume produce_mail_merge_exit \par End Function \par \par \par Private Sub Class_Initialize() \par Set obj_wrd_routines = New i_word_routines \par End Sub \par \par \par Private Sub Class_Terminate() \par Set obj_wrd_routines = Nothing \par End Sub \par \par \par \par } |
Creating a Word Mail merge document using a Record |
India web developer web development India | India web development company India ecommerce web developer