Revolution1200
Programmer
Hi All,
The problem is my current code is very slow.
We have multiple word document templates that we use for merging purposes - this is due to people being assigned different letters in the database depending on processing.
We need to merge these into one final document for mailing.
The data for this comes from an excel spreadsheet which has the following format
Field 1 - Letter Identifier to use IE template
Field 2 - Title
Field 3 - Initials
Field 4 - Surname
Field 5 - Address details
An example of the records could be
identifier name address details
template1 test name some address
template2 test name some address 2
template1 test name some address 3
The final merged document will be made up of Template1, template2 and a final template1.
The order has to be the same as the file as this is in UK Royal Mail Mailsort order.
Current Code I have is
Can anyone suggest a quicker way of doing this?
Cheers
Stuart
The problem is that this is very slow, is there a better way of doing this?
The problem is my current code is very slow.
We have multiple word document templates that we use for merging purposes - this is due to people being assigned different letters in the database depending on processing.
We need to merge these into one final document for mailing.
The data for this comes from an excel spreadsheet which has the following format
Field 1 - Letter Identifier to use IE template
Field 2 - Title
Field 3 - Initials
Field 4 - Surname
Field 5 - Address details
An example of the records could be
identifier name address details
template1 test name some address
template2 test name some address 2
template1 test name some address 3
The final merged document will be made up of Template1, template2 and a final template1.
The order has to be the same as the file as this is in UK Royal Mail Mailsort order.
Current Code I have is
Code:
Dim oSR As Word.Range
Dim oFld As Word.Field
Dim oRange As Word.Range
Dim szField() As String
Dim lState As Long
Dim mainApplication As Excel.Application
Dim path As String
Dim ado, rs
Dim numLetters As Integer
Dim loadedLetters As Integer
Dim change As Boolean
Dim newData As String
Dim oMySR As Word.Range
Dim oMyField As Word.Field
Dim currRecord As Long
Dim i As Integer
'open our spreadsheet and get a count of distinct letters used
path = "C:\N_LET0304_356.xls"
Set ado = CreateObject("ADODB.Connection")
ado.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & path & ";Extended Properties=Excel 8.0;Persist Security Info=False"
ado.Open
Set rs = ado.Execute("SELECT Distinct LETTER FROM [N_LET0304_356$]")
numLetters = 0
While Not rs.EOF
numLetters = numLetters + 1
rs.MoveNext
Wend
rs.Close
'create our word application
Set wordapp = New Word.Application
Do While wordapp = ""
Set wordapp = New Word.Application
i = i + 1
If i = 5 Then
MsgBox "Error creating word object - form will close"
End If
Loop
'for testing
wordapp.Visible = False
wordapp.ScreenUpdating = False
'now load our letter templates that we require
ReDim doc2(numLetters)
loadedLetters = 0
Set rs = ado.Execute("SELECT DISTINCT LETTER FROM [N_LET0304_356$]")
While Not rs.EOF
Set doc2(loadedLetters) = wordapp.Documents.Open(fileName:="C:\Dayend Letters\" & rs.Fields(0) & ".doc", _
ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, _
PasswordDocument:="", PasswordTemplate:="", Revert:=False, _
WritePasswordDocument:="", WritePasswordTemplate:="", Format:= _
wdOpenFormatAuto)
rs.MoveNext
Wend
rs.Close
Set rs = Nothing
'for testing
wordapp.Visible = False
Set doc1 = wordapp.Documents.Add
Set doc3 = wordapp.Documents.Add
currRecord = 1
Label4.Caption = CStr(currRecord)
'ok our main loop - run through the records
Set rs = ado.Execute("SELECT * FROM [N_LET0304_356$]")
While Not rs.EOF
'delete any text currently in our working document
wordapp.Windows("Document2").Activate
wordapp.Selection.WholeStory
wordapp.Selection.TypeBackspace
wordapp.Selection.TypeBackspace
wordapp.Selection.Delete Unit:=wdCharacter, count:=1
'now we need to select the correct template and copy the details to Doc3 ready to setup the merge
wordapp.Windows(CStr(Trim(rs.Fields(0)) & ".doc")).Activate
wordapp.Selection.WholeStory
wordapp.Selection.Copy
wordapp.Windows("Document2").Activate
wordapp.Selection.PasteAndFormat (wdPasteDefault)
wordapp.Selection.TypeBackspace
'this section adds our details
'For Each oSR In doc3.StoryRanges
Set oSR = doc3.StoryRanges(1)
For Each oFld In oSR.Fields
' the "wordfield.code" is in the format "MERGEFIELD fieldname". Use the
' SPLIT command (with space as the field delimeter) to put the two or more values
' into an array, and the merge field name will be in element 2 of the
' array.
If (Left(oFld.Code, Len(" MERGEFIELD")) = " MERGEFIELD") Then
szField = Split(oFld.Code, " ")
change = False
newData = ""
szField(2) = Replace(szField(2), Chr(34), "", , , vbBinaryCompare)
Select Case LCase(szField(2))
Case "title"
change = True
newData = rs.Fields(1) & vbNullString
Case "initials"
change = True
newData = rs.Fields(2) & vbNullString
Case "surname"
change = True
newData = rs.Fields(3) & vbNullString
Case "a1"
change = True
newData = rs.Fields(4) & vbNullString
Case "a2"
change = True
newData = rs.Fields(5) & vbNullString
Case "a3"
change = True
newData = rs.Fields(6) & vbNullString
Case "a4"
change = True
newData = rs.Fields(7) & vbNullString
Case "a5"
change = True
newData = rs.Fields(8) & vbNullString
Case "a6"
change = True
newData = rs.Fields(9) & vbNullString
Case "a7"
change = True
newData = rs.Fields(10) & vbNullString
Case "ref1"
change = True
newData = rs.Fields(11) & vbNullString
Case "ref2"
change = True
newData = rs.Fields(12) & vbNullString
Case "ref3"
change = True
newData = rs.Fields(13) & vbNullString
End Select
If change Then
oFld.Select
Set oRange = wordapp.Selection.Range
'oRange.Text = Format(Date, "DD MMMM YYYY")
oRange.Text = newData
End If
End If
Next
'Next
'now copy all the data over to the bottom of doc1
wordapp.Selection.WholeStory
wordapp.Selection.Copy
wordapp.Windows("Document1").Activate
wordapp.Selection.PasteAndFormat (wdPasteDefault)
wordapp.Selection.TypeBackspace
wordapp.Selection.InsertBreak Type:=wdPageBreak
rs.MoveNext
currRecord = currRecord + 1
Label4.Caption = CStr(currRecord)
Wend
rs.Close
Set rs = Nothing
ado.Close
Set ado = Nothing
wordapp.Windows("Document1").Activate
wordapp.ActiveDocument.SaveAs "C:\testfile.doc"
wordapp.Quit False
Set wordapp = NothingCan anyone suggest a quicker way of doing this?
Cheers
Stuart
The problem is that this is very slow, is there a better way of doing this?
