Access as a performance typer

G

Guest

Is there a faster method than "docWord.Range(docRange.Start).InsertAfter" to
place text into word? Bookmarks are out of the question since i do not know
the lenght of the document and i am formatting and adding tables on the fly.

thank you

_________________________________________________________
I know you guys like code:

Public Sub wordMapping(ByVal tmpPath As String)

Dim appWord As Word.Application ' for working with MS Word
Dim docWord As Word.Document ' MS Word document
Dim docRange As Word.Range ' Range for entering text into word

Dim rds As DAO.Recordset
Dim strTemplate As String

Dim tmpStr As String
Dim tmpTable As String
Dim tmpField As String
Dim tmpSystemL As String
Dim tmpSystemN As String

Dim dtStart As Date
Dim dtEnd As Date

Dim i As Integer
Dim iconErr As Integer
Dim progBarC As Control

dtStart = Now()
iconErr = 0

progFrmShow True, False, dtStart

Set progBarC = Forms!frmAppProgress!progBarCurrent
progBarC = 0

strTemplate = "SupportFiles\wordTemplate.dot"

Set rds = CurrentDb.OpenRecordset(strSQLMapping, dbOpenDynaset, dbSeeChanges)
If rds.EOF Then iconErr = 2: GoTo 10

rds.MoveLast
progBarC.Max = rds.RecordCount
rds.MoveFirst

' set reference to MS Word. If an application is already running then use
the current instance
On Error Resume Next
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then Set appWord = CreateObject("Word.Application"):
Err.Clear

' Open a new document from the template
Set docWord = appWord.Documents.Add(tmpPath & "\" & strTemplate)

' save the document and assign a name
docWord.SaveAs tmpPath & "\Mapping " & rds![NewSystem].Value & " " &
rds![legacySystem].Value & " " & strDate(dtStart) & " " & strTime(dtStart) &
".doc"
i = 0

'set the 'range' where the text will be entered
Set docRange = docWord.Paragraphs(1).Range
docRange.Collapse wdCollapseEnd

' loop through the Field query
Do Until rds.EOF

' Begin a new section for each New System name
If rds![NewSystem].Value <> tmpSystemN Then
docWord.Range(docRange.Start).Style = docWord.Styles("Heading 1")
docWord.Range(docRange.Start).InsertAfter rds![NewSystem].Value
docWord.Range(docRange.Start).InsertAfter vbCrLf
docRange.MoveStart wdStory, 1

tmpSystemN = rds![NewSystem].Value
End If ' New System

' Begin a new section for each Legacy System name
If rds![legacySystem].Value <> tmpSystemL Then
docWord.Range(docRange.Start).Style = docWord.Styles("Heading 2")
docWord.Range(docRange.Start).InsertAfter rds![legacySystem].Value
docWord.Range(docRange.Start).InsertAfter vbCrLf
docRange.MoveStart wdStory, 1

tmpSystemL = rds![legacySystem].Value
End If

' Begin a new section for each New Table
If rds![newTable].Value <> tmpTable Then
docWord.Range(docRange.Start).Style = docWord.Styles("Heading 3")
docWord.Range(docRange.Start).InsertAfter rds![newTable].Value
docWord.Range(docRange.Start).InsertAfter vbCrLf
docRange.MoveStart wdStory, 1

tmpTable = rds![newTable].Value

docWord.Range.Tables.Add docRange, 1, 4, wdWord8TableBehavior,
wdAutoFitFixed
i = i + 1

docWord.Range(docRange.Start).Style = docWord.Styles("Normal")

' format the table
docWord.Tables(i).Style = "Table Professional"
docWord.Tables(i).PreferredWidthType = wdPreferredWidthPoints
docWord.Tables(i).Columns(1).PreferredWidthType = wdPreferredWidthPoints
docWord.Tables(i).Columns(2).PreferredWidthType = wdPreferredWidthPoints
docWord.Tables(i).Columns(3).PreferredWidthType = wdPreferredWidthPoints

docWord.Tables(i).PreferredWidth = 0

docWord.Tables(i).Columns(1).PreferredWidth = InchesToPoints(2)
docWord.Tables(i).Columns(2).PreferredWidth = InchesToPoints(0.8)
docWord.Tables(i).Columns(3).PreferredWidth = InchesToPoints(0.8)
docWord.Tables(i).Columns(4).PreferredWidth = InchesToPoints(3.3)

' add header text
docWord.Tables(i).Cell(1, 1).Range.InsertAfter "Field"
docWord.Tables(i).Cell(1, 2).Range.InsertAfter "Required"
docWord.Tables(i).Cell(1, 3).Range.InsertAfter "Phase"
docWord.Tables(i).Cell(1, 4).Range.InsertAfter "Legacy Table / Field"

docWord.Range(docRange.Start).InsertAfter vbCrLf

End If

docRange.MoveStart wdStory, 1

If rds![newField].Value <> tmpField Then

docWord.Tables(i).Rows.Add
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
1).Range.InsertAfter rds![newField].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
2).Range.InsertAfter rds![nameMand].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
3).Range.InsertAfter rds![namePhase].Value
tmpField = rds![newField].Value

tmpStr = rds![legacyTable].Value & " / " & rds![legacyField].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
4).Range.InsertAfter tmpStr

Else

tmpStr = vbCrLf & rds![legacyTable].Value & " / " &
rds![legacyField].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
4).Range.InsertAfter tmpStr

End If

progBarC = progBarC + 1
rds.MoveNext
Loop

' Save the application and quit MS Word
docWord.Close wdSaveChanges
If appWord.Visible = False Then appWord.Quit

10 dtEnd = Now()
progFrmFinished dtStart, dtEnd, iconErr, IIf((iconErr <> 0), "No Records for
Report.", "")

' Freeing variables
rds.Close

Set docRange = Nothing
Set docWord = Nothing
Set appWord = Nothing
Set rds = Nothing

End Sub
 
D

Douglas J. Steele

While you may be running this code from Access, I think you'd be better off
asking in one of the Word newsgroups, since your question is specific to
Word methods.

--
Doug Steele, Microsoft Access MVP

(no e-mails, please!)


rogge said:
Is there a faster method than "docWord.Range(docRange.Start).InsertAfter"
to
place text into word? Bookmarks are out of the question since i do not
know
the lenght of the document and i am formatting and adding tables on the
fly.

thank you

_________________________________________________________
I know you guys like code:

Public Sub wordMapping(ByVal tmpPath As String)

Dim appWord As Word.Application ' for working with MS Word
Dim docWord As Word.Document ' MS Word document
Dim docRange As Word.Range ' Range for entering text into word

Dim rds As DAO.Recordset
Dim strTemplate As String

Dim tmpStr As String
Dim tmpTable As String
Dim tmpField As String
Dim tmpSystemL As String
Dim tmpSystemN As String

Dim dtStart As Date
Dim dtEnd As Date

Dim i As Integer
Dim iconErr As Integer
Dim progBarC As Control

dtStart = Now()
iconErr = 0

progFrmShow True, False, dtStart

Set progBarC = Forms!frmAppProgress!progBarCurrent
progBarC = 0

strTemplate = "SupportFiles\wordTemplate.dot"

Set rds = CurrentDb.OpenRecordset(strSQLMapping, dbOpenDynaset,
dbSeeChanges)
If rds.EOF Then iconErr = 2: GoTo 10

rds.MoveLast
progBarC.Max = rds.RecordCount
rds.MoveFirst

' set reference to MS Word. If an application is already running then use
the current instance
On Error Resume Next
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then Set appWord = CreateObject("Word.Application"):
Err.Clear

' Open a new document from the template
Set docWord = appWord.Documents.Add(tmpPath & "\" & strTemplate)

' save the document and assign a name
docWord.SaveAs tmpPath & "\Mapping " & rds![NewSystem].Value & " " &
rds![legacySystem].Value & " " & strDate(dtStart) & " " & strTime(dtStart)
&
".doc"
i = 0

'set the 'range' where the text will be entered
Set docRange = docWord.Paragraphs(1).Range
docRange.Collapse wdCollapseEnd

' loop through the Field query
Do Until rds.EOF

' Begin a new section for each New System name
If rds![NewSystem].Value <> tmpSystemN Then
docWord.Range(docRange.Start).Style = docWord.Styles("Heading 1")
docWord.Range(docRange.Start).InsertAfter rds![NewSystem].Value
docWord.Range(docRange.Start).InsertAfter vbCrLf
docRange.MoveStart wdStory, 1

tmpSystemN = rds![NewSystem].Value
End If ' New System

' Begin a new section for each Legacy System name
If rds![legacySystem].Value <> tmpSystemL Then
docWord.Range(docRange.Start).Style = docWord.Styles("Heading 2")
docWord.Range(docRange.Start).InsertAfter rds![legacySystem].Value
docWord.Range(docRange.Start).InsertAfter vbCrLf
docRange.MoveStart wdStory, 1

tmpSystemL = rds![legacySystem].Value
End If

' Begin a new section for each New Table
If rds![newTable].Value <> tmpTable Then
docWord.Range(docRange.Start).Style = docWord.Styles("Heading 3")
docWord.Range(docRange.Start).InsertAfter rds![newTable].Value
docWord.Range(docRange.Start).InsertAfter vbCrLf
docRange.MoveStart wdStory, 1

tmpTable = rds![newTable].Value

docWord.Range.Tables.Add docRange, 1, 4, wdWord8TableBehavior,
wdAutoFitFixed
i = i + 1

docWord.Range(docRange.Start).Style = docWord.Styles("Normal")

' format the table
docWord.Tables(i).Style = "Table Professional"
docWord.Tables(i).PreferredWidthType = wdPreferredWidthPoints
docWord.Tables(i).Columns(1).PreferredWidthType =
wdPreferredWidthPoints
docWord.Tables(i).Columns(2).PreferredWidthType =
wdPreferredWidthPoints
docWord.Tables(i).Columns(3).PreferredWidthType =
wdPreferredWidthPoints

docWord.Tables(i).PreferredWidth = 0

docWord.Tables(i).Columns(1).PreferredWidth = InchesToPoints(2)
docWord.Tables(i).Columns(2).PreferredWidth = InchesToPoints(0.8)
docWord.Tables(i).Columns(3).PreferredWidth = InchesToPoints(0.8)
docWord.Tables(i).Columns(4).PreferredWidth = InchesToPoints(3.3)

' add header text
docWord.Tables(i).Cell(1, 1).Range.InsertAfter "Field"
docWord.Tables(i).Cell(1, 2).Range.InsertAfter "Required"
docWord.Tables(i).Cell(1, 3).Range.InsertAfter "Phase"
docWord.Tables(i).Cell(1, 4).Range.InsertAfter "Legacy Table / Field"

docWord.Range(docRange.Start).InsertAfter vbCrLf

End If

docRange.MoveStart wdStory, 1

If rds![newField].Value <> tmpField Then

docWord.Tables(i).Rows.Add
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
1).Range.InsertAfter rds![newField].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
2).Range.InsertAfter rds![nameMand].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
3).Range.InsertAfter rds![namePhase].Value
tmpField = rds![newField].Value

tmpStr = rds![legacyTable].Value & " / " & rds![legacyField].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
4).Range.InsertAfter tmpStr

Else

tmpStr = vbCrLf & rds![legacyTable].Value & " / " &
rds![legacyField].Value
docWord.Tables(i).Cell(docWord.Tables(i).Rows.Count,
4).Range.InsertAfter tmpStr

End If

progBarC = progBarC + 1
rds.MoveNext
Loop

' Save the application and quit MS Word
docWord.Close wdSaveChanges
If appWord.Visible = False Then appWord.Quit

10 dtEnd = Now()
progFrmFinished dtStart, dtEnd, iconErr, IIf((iconErr <> 0), "No Records
for
Report.", "")

' Freeing variables
rds.Close

Set docRange = Nothing
Set docWord = Nothing
Set appWord = Nothing
Set rds = Nothing

End Sub
Click to expand...
 
Top