Problem with code to create a word doc

[jonney]

Hi there

I have this bit of code which is in an Access 97 database (below), which creates a new version of a word document. However it is not working. It is stopping at the section Marked:"Next bit is Deleting of old issue date and inserting new IssueDate bookmark to allow new issue to accept date when it is issued" and marked in red

Can anyone help?

Thanks

Jonney


Private Sub cmdNewVersion_Click()
On Error GoTo Err_cmdNewVersion_Click

Dim oWord As Word.Application
Dim oDoc As New Word.Document
Dim oExcel As Excel.Application, oSS As Excel.Workbook
Dim VerType As Integer
Dim strDoc As String

VerType = MsgBox("Create a Major issue? Click No for Minor issue.", vbYesNoCancel, "Major New Issue")
If VerType = vbCancel Then Exit Sub

If VerType = vbYes Then
MaxVer = Int(Version) + 1
ElseIf VerType = vbNo Then
MaxVer = Version + 0.1
End If

DoCmd.SetWarnings False

If Forms!frmNewDocument!Excel = False Then

strDoc = DocPath & TreeName & "(" & Format(Version, "0.0") & ")" & ".doc"

Set oWord = CreateObject("Word.Application")
Set oDoc = oWord.Documents.Open(strDoc)

'Next bit is Deleting of old issue date and inserting new IssueDate bookmark to allow new issue to accept date when it is issued

With oWord
if oDoc.ActiveWindow.View.SplitSpecial <> wdPaneNone Then
If .ActiveWindow.View.SplitSpecial <> wdPaneNone Then
.ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Or ActiveWindow.ActivePane.View.Type _
= wdMasterView Then
.ActiveWindow.ActivePane.View.Type = wdPageView
End If

.ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
.Selection.MoveDown Unit:=wdLine, Count:=4
.Selection.EndKey Unit:=wdLine
.Selection.TypeBackspace
.Selection.TypeBackspace
.Selection.TypeBackspace
.Selection.TypeBackspace
.Selection.TypeBackspace
.Selection.TypeBackspace
.Selection.TypeBackspace
.Selection.TypeBackspace
With ActiveDocument.Bookmarks
.Add Range:=Selection.Range, Name:="IssueDate"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
.ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
'Deleting of old issue date and inserting new IssueDate bookmark finishes here

oDoc.SaveAs DocPath & TreeName & "(" & Format(MaxVer, "0.0") & ")" & ".doc"
oDoc.Close: oWord.Quit
Set oDoc = Nothing: Set oWord = Nothing

Else

strDoc = DocPath & TreeName & "(" & Format(Version, "0.0") & ")" & ".xls"

On Error Resume Next
Set oExcel = GetObject(, "Excel.Application")
If oExcel Is Nothing Then Set oExcel = New Excel.Application

Set oSS = oExcel.Workbooks.Open(strDoc)
oSS.SaveAs DocPath & TreeName & "(" & Format(MaxVer, "0.0") & ")" & ".xls"
oSS.Close: oExcel.Quit
Set oSS = Nothing: Set oExcel = Nothing

End If

Me.Refresh
DoCmd.RunCommand acCmdRemoveFilterSort
Forms!frmNewDocument!ID.Visible = True
DoCmd.GoToControl "ID"
DoCmd.RunCommand acCmdSortDescending
DoCmd.OpenForm "frmNewDocument", acNormal, "", "[compid]=[Forms]![frmNewDocument]![id]", , acNormal
DoCmd.GoToControl "TreeName"
Forms!frmNewDocument!ID.Visible = False
DoCmd.Echo True

DoCmd.SetWarnings False
DoCmd.RunMacro "mcrNewVersion.Reason" 'colin added to prompt users to explain the reason for the new version
DoCmd.OpenQuery "qryNewVersionEditorPreviousOwner", acNormal, acEdit 'appends approver's by department - make's sure if owner is changed they get added to list of approvers if necessary
DoCmd.RunMacro "mcrDocumentNewForm.refreshapprovers" 'refreshes new list of approvers

MsgBox "Remember to update the Issue Number and delete the Issued Date in the header of the document - this is not done automatically", , "Issue Number and Date"

Exit_cmdNewVersion_Click:
Exit Sub

Err_cmdNewVersion_Click:
MsgBox Err.Description
Resume Exit_cmdNewVersion_Click
End With
End If
End Sub

 

[PHV]

You may try to replace this:
Dim oDoc As New Word.Document
By this:
Dim oDoc As Word.Document

Hope This Helps, PH.
Want to get great answers to your Tek-Tips questions? Have a look at FAQ219-2884 or FAQ181-2886

 

[jonney]

Thanks for the prompt reply. That seems to have done the trick. Many thanks