I used code Written by Helen Feddema 4-22-98
'Last modified 8-2-2000
Private Sub Command50_Click()
Dim appWord As Word.Application
Dim docs As Word.Documents
Dim doc As Object
Dim strLetter As String
Dim strTemplateDir As String
Dim strLetterDir As String
Dim strDocID As String
Dim prps As Object
Dim strDate As String
Dim strWordDoc As String
Dim strString As String
Dim strGeachte As String
Dim strTav As String
Dim strMedewerker As String
Dim strSofinummer As String
Dim strGeboortedatum As String
Dim strAdres As String
Dim strPostcodeplaats As String
Dim strTelefoonr As String
Dim strTelefoonw As String
Dim strAanhefrel As String
Dim strEindArbeidproces As String
Dim strContactpersoonbedrijf As String
Dim strBedrijfsnaam As String
Dim strPlaats As String
Dim strPostcode As String
Dim strStraat As String
Dim rs As Recordset
Dim ctl As Access.Control
Dim Rec As Integer
' DoCmd.OpenForm "Instellingen", , , , , acHidden 'Toegevoegd 16-5
' strDocPad = Forms![Instellingen]![Doc pad] 'Toegevoegd 16-5
'DoCmd.Close acForm, "Instellingen"
If appWord Is Nothing Then ' Sets variable to the running instance of the Word ' Global object (which is nearly the same as Word.Application)...
Set appWord = CreateObject("Word.Application")
'MsgBox "Word wordt geopend"
End If
If Nz(Me![Document].Value) = True Then
MsgBox " Kies een document"
End If
strWordDoc = Nz(Me![Document].Value)
Set ctl = Me![Document]
If strWordDoc = "" Then
MsgBox "Kies een document"
ctl.SetFocus
ctl.Dropdown
GoTo ErrorHandlerExit
End If
On Error GoTo ErrorHandler
Nieuw_doc:
Set appWord = GetObject(, "Word.Application")
If Err.Number <> 0 Then
MsgBox "de code hapert bij Get Object" & Err.Source & Err.Number
Err.Clear
Set appWord = CreateObject("Word.Application")
If Err.Number <> 0 Then
' MsgBox "Word wordt geopend"
Err.Clear
End If
End If
strDate = CStr(Date)
strTemplateDir = appWord.Options.DefaultFilePath(wdUserTemplatesPath)
strTemplateDir = strTemplateDir & "\Personal Documents\"
'strTemplateDir = "E:\Personal Documents\"
strLetter = strTemplateDir & strWordDoc & ".dot"
Debug.Print "Letter: " & strLetter
Set docs = appWord.Documents
docs.Add strLetter
Set doc = appWord.ActiveDocument 'Toegevoegd
appWord.Visible = True 'Toegevoegd
Debug.Print " Pad van actief document=" & doc.Path & doc.Name 'activeDocument vervangen door doc
'zetten van de bookmarks vanuit database
strTav = Nz(Me![TabBedrijven Subform].Form![Tav]) & " " & Nz(Me![TabBedrijven Subform].Form![Voorletters]) & " " & Nz(Me![TabBedrijven Subform].Form![Contactpersoon bedrijf])
strGeachte = Nz(Me![TabBedrijven Subform].Form![Geachte]) & " " & Nz(Me![TabBedrijven Subform].Form![Contactpersoon bedrijf])
strMedewerker = Nz(Me![Aanhef]) & " " & Nz(Me![Voorletters]) & " " & Nz(Me![Voorvoegsel]) & " " & Nz(Me![Achternaam])
strSofinummer = Nz(Me![Sofi nummer])
strAdres = Nz(Me![Bezoekadres])
strPostcodeplaats = Nz(Me![Postcode]) & " " & Nz(Me![Plaats])
strTelefoonr = Nz(Me![Telefoonnummer])
strTelefoonw = Nz(Me![TabBedrijven Subform].Form![Telefoonnummer bedrijf])
strAanhefrel = Nz(Me![Geachte]) & " " & Nz(Me![Voorvoegsel]) & " " & Nz(Me![Achternaam])
strEindArbeidproces = Nz(Me![Eind arbeidsproc])
strContactpersoonbedrijf = strTav
strBedrijfsnaam = Nz(Me![TabBedrijven Subform].Form![Naam bedrijf])
strGeboortedatum = Nz(Me![Geboortedatum])
strPlaats = Nz(Me![TabBedrijven Subform].Form![Plaats])
strPostcode = Nz(Me![TabBedrijven Subform].Form![Postcode])
strStraat = Nz(Me![TabBedrijven Subform].Form![Straat])
'gemeenschappelijke bookmarks adresgegevens bedrijf en kop brief
With appWord.Selection
.GoTo What:=wdGoToBookmark, Name:="Bedrijfsnaam"
.TypeText Text:=strBedrijfsnaam
.GoTo What:=wdGoToBookmark, Name:="Plaats"
.TypeText Text:=Nz(Me![TabBedrijven Subform].Form![Plaats])
.GoTo What:=wdGoToBookmark, Name:="Medewerker"
.TypeText Text:=strMedewerker
.GoTo What:=wdGoToBookmark, Name:="Sofinummer"
.TypeText Text:=strSofinummer
.GoTo What:=wdGoToBookmark, Name:="Geboortedatum"
.TypeText Text:=strGeboortedatum
.GoTo What:=wdGoToBookmark, Name:="Bezoekadres"
.TypeText Text:=Nz(Me![Bezoekadres]) & ", " & Nz(Me![Postcode]) & " " & Nz(Me![Plaats])
.GoTo What:=wdGoToBookmark, Name:="Datum" 'Datum hier toegevoegd
.TypeText Text:=strDate
End With
'Idem behalve voor "Info Medisch BenG"
If strWordDoc <> "Info Medisch BenG" Then 'Deze bookmarks niet
With appWord.Selection
.GoTo What:=wdGoToBookmark, Name:="Contactpersoon_Bedrijf"
.TypeText Text:=strTav
If strWordDoc <> "Terugkoppeling" Then 'Bij formulier terugkoppeling het volgende niet
.GoTo What:=wdGoToBookmark, Name:="Straat"
.TypeText Text:=Nz(Me![TabBedrijven Subform].Form![Straat])
.GoTo What:=wdGoToBookmark, Name:="Postcode"
.TypeText Text:=Nz(Me![TabBedrijven Subform].Form![Postcode])
.GoTo What:=wdGoToBookmark, Name:="Werknemernummer"
.TypeText Text:=Nz(Me![Werknemernummer])
.GoTo What:=wdGoToBookmark, Name:="Aanhef"
.TypeText Text:=strGeachte
End If
End With
Else
With appWord.Selection
.GoTo What:=wdGoToBookmark, Name:="Functie"
.TypeText Text:=Nz(Me![Functie])
End With
With appWord.Selection
'Datum hier weggehaald
.GoTo What:=wdGoToBookmark, Name:="Medewerker2"
.TypeText Text:=strMedewerker
End With
End If
If strWordDoc = "nokd BenG" Then
With appWord.Selection
.GoTo What:=wdGoToBookmark, Name:="Eind_arbeidsproces"
.TypeText Text:=Nz(Me![Eind arbeidsproc])
.GoTo What:=wdGoToBookmark, Name:="Medewerker2"
.TypeText Text:=strMedewerker
End With
End If
If strWordDoc = "su volledig ao Beng" Or strWordDoc = "su volledig ag Beng" Or strWordDoc = "ivra2 leeg" Then
With appWord.Selection
.GoTo What:=wdGoToBookmark, Name:="Eind_arbeidsproces"
.TypeText Text:=Nz(Me![Eind arbeidsproc])
End With
End If
If strWordDoc = "uitnodiging BenG-G" Or strWordDoc = "uitnodiging BenG-G" Then
With appWord.Selection
.GoTo What:=wdGoToBookmark, Name:="Eind_arbeidsproces"
.TypeText Text:=Nz(Me![Eind arbeidsproc])
End With
End If
With appWord
.Visible = True
.Activate
.Selection.WholeStory
.Selection.Fields.Update
.Selection.MoveDown Unit:=wdLine, Count:=1
End With
Me("Sub verzonden").SetFocus
Rec = Me.[Sub verzonden].Form.RecordsetClone.RecordCount + 1
DoCmd.GoToRecord , , acGoTo, Rec
Me![Sub verzonden].Form![RelatieID] = Me!RelatieID
Me![Sub verzonden].Form![Datum verstuurd] = strDate
strDocID = str(Me!RelatieID) & "-" & str(Rec)
If Geert = 1 Then 'Toegevoegd mei 2006
strDocID = strDocID & "G"
Else
strDocID = strDocID & "J"
End If
strLetterDir = strDocPad & strWordDoc & strDocID
Me![Sub verzonden].Form![Document] = strWordDoc & strDocID 'Tot hier
If strWordDoc = "Leeg document" Then
appWord.Visible = False
strWordDoc = InputBox("Onder welke naam wilt u het lege document opslaan?", , , 5000, 5000)
Me![Sub verzonden].Form![Document] = strWordDoc
strLetterDir = strDocPad & strWordDoc
With appWord
.Visible = True
.Activate
.Selection.WholeStory
.Selection.Fields.Update
.Selection.MoveDown Unit:=wdLine, Count:=1
End With
End If
Refresh
Debug.Print strLetterDir
doc.SaveAs FileName:=strLetterDir 'ActiveDocument vervangen door doc
' MsgBox " Uw document is opgeslagen in :" & strLetterDir
ErrorHandlerExit:
Exit Sub
ErrorHandler:
If Err = 429 Then
MsgBox "Word is not running; open Word with CreateObject"
Set appWord = CreateObject("Word.Application")
Resume Next
Else
' If Err.Number = 462 Then
' MsgBox " error 462 gevonden"
' Err.Clear
' Resume Next
' End If
MsgBox "Error No: " & Err.Number & "; Description: " & Err.Description
Resume ErrorHandlerExit
End If
End Sub