'------------------------------------------------------------------------------------------
' Export2Word
'
' Exporteerd de gegevens in query [BronNaam] naar een bestand dat gebaseerd is
' op het sjabloon [SJabloonNaam] en zet deze in de directory [ExportMap].
'------------------------------------------------------------------------------------------
Function Export2Word(BronNaam As String, SjabloonNaam As String, ExportMap As String, _
Optional Pbar As Object) As Boolean
Dim Rc As DAO.Recordset
Dim Fld As DAO.Field
Dim Wrd As Object
Dim WrdDoc As Object
Dim MyRange As Object
Dim WordWasOpen As Boolean
Dim ShowProgress As Boolean
Dim FieldCounter As Long
Dim ExportDocumentNaamVeld As String
Dim ExportDocumentNaam As String
Dim Tag As String ' Mag een maximale lengte hebben van 30 karakters
Dim TagStr As String
Dim ListString As String
Dim RcTemp As DAO.Recordset
Dim StrVar As Variant
Dim i As Integer
'Sjabloon is niet aanwezig
If Len(Dir(SjabloonNaam)) = 0 Then Exit Function
ExportMap = ValidatePath(ExportMap)
'Exportmap is niet aanwezig
If Len(ExportMap) = 0 Then Exit Function
If Not (Pbar Is Nothing) Then ShowProgress = True
On Error GoTo WordNotOpen
WordWasOpen = True
Set Wrd = GetObject(, "Word.Application")
On Error GoTo 0
Set Rc = CurrentDb.OpenRecordset(BronNaam, dbOpenDynaset, dbReadOnly)
If Not Rc.EOF Then
'Zoek of er een veld Document naam is op vrij losse overeenkomst
For Each Fld In Rc.Fields
If InStr(1, UCase(Fld.Name), "DOCUMENTNAAM") Then
ExportDocumentNaamVeld = Fld.Name
Exit For
End If
Next
'Er is geen veld documentnaam gevonden zodoende kan er geen export plaats vinden.
If Len(ExportDocumentNaamVeld) = 0 Then Exit Function
Set WrdDoc = Wrd.Documents.Open(SjabloonNaam)
If ShowProgress Then
Pbar.Min = 0
Pbar.Max = Rc.Fields.Count + 1
Pbar.Value = 0
Pbar.Visible = True
End If
Rc.MoveFirst
Do While Not Rc.EOF
ExportDocumentNaam = Rc.Fields(ExportDocumentNaamVeld)
ExportDocumentNaam = CleanFileName(ExportDocumentNaam)
WrdDoc.SaveAs (ExportMap & ExportDocumentNaam)
Set MyRange = WrdDoc.Content
'Doorloop alle velden
For FieldCounter = 0 To Rc.Fields.Count - 1
Tag = "[" & UCase(Rc.Fields(FieldCounter).Name) & "]"
TagStr = UCase(Mid$(Tag, 2, 4))
Select Case TagStr
Case "LIST" ' Het is een lijst die moet worden aangemaakt.
ListString = ""
'Samenstellen lijst
Do While Rc.Fields(ExportDocumentNaamVeld).Value = ExportDocumentNaam
ListString = ListString & Rc.Fields(FieldCounter) & vbCr
Rc.MoveNext
'controle einde recordset
If Rc.EOF Then
Exit Do
End If
Loop
MyRange.Find.Execute Tag, True, True, False, False, False, , 1, , ListString, 2
Rc.MovePrevious
Case "MEMO" ' Het is een memoveld.
Set RcTemp = CurrentDb.OpenRecordset(BronNaam, dbReadOnly, dbForwardOnly)
'Rc.MoveFirst ' bij dynamische cursor is nu (cursorless) niet nodig.
StrVar = LoadMemoTekstInVariantArray(Rc.Fields(Tag))
RcTemp.Close
Set RcTemp = Nothing
' Schrijf strings met string + Tag
For i = LBound(StrVar) To UBound(StrVar)
If i <> UBound(StrVar) Then
'Schrijf de string EN de Tag
MyRange.Find.Execute Tag, True, True, False, False, False, , 1, , StrVar(i) & Tag, 2
Else
'Schrijf alleen de string
MyRange.Find.Execute Tag, True, True, False, False, False, , 1, , StrVar(i), 2
End If
Next
Case Else
'Tag vervangen door veldwaarde
MyRange.Find.Execute Tag, True, True, False, False, False, , 1, , Rc.Fields(FieldCounter).Value, 2
End Select
If ShowProgress Then Pbar = Pbar + 1
Next
Rc.MoveNext
If ShowProgress Then Pbar = Pbar + 1
WrdDoc.Save
WrdDoc.Close False
Set WrdDoc = Wrd.Documents.Open(SjabloonNaam)
Loop
End If
WrdDoc.Close False
If Not WordWasOpen Then Wrd.Quit False
Rc.Close
Set Rc = Nothing
Set Wrd = Nothing
If ShowProgress Then Pbar.Visible = False
Exit Function
WordNotOpen:
WordWasOpen = False
Set Wrd = CreateObject("Word.Application")
Resume Next
End Function
