On 12 Jan 2006 00:23:29 -0800,
fo******@gmail. com wrote:
Gday,
I have a set of Access 2000 tables that I would like to export into a
MS Word 2000 template at specific bookmark locations that I've set up.
Would anyone know the code to achieve something like this? I've heard
about using the OutPutTo method, but I'm not sure if it can output to a
specific bookmark location.
I have just made it, using automatation. Following sub opens a new word
document file, based on template with the appropiate bookmarks and other
fixed stuf.
<vba_code>
Enum wordCommand
gotoBMIns
indent
indentBack
gotoBM
ins
insFootNote
End Enum
'1 arg: array of word commands and their content
'2 arg: destination file for new word document
'3 arg: template source
Public Function MergetoWord(mer geContent, _
Optional destFile$ =
"C:\usr\benny\w ork\jobs\kontak t\Systemmatiser et\ans.doc", _
Optional Skabelon$ = "E:\Program Files\Microsoft
Office\Skabelon er\jobans.dot")
' This method creates a new document in MS Word 97 using Automation.
On Error Resume Next
Dim rsCust As Recordset, cI%, cBound%, indent As New Stack
Dim WordObj As Word.Applicatio n
indent.push 0
DoCmd.Hourglass True
Set WordObj = GetObject(, "Word.Applicati on.8")
If err.Number <> 0 Then
Set WordObj = CreateObject("W ord.Application .8")
End If
WordObj.Visible = True
WordObj.Documen ts.Add Template:=Skabe lon, NewTemplate:=Fa lse
cBound = UBound(mergeCon tent)
cI = 0
Do
Select Case mergeContent(cI )
Case wordCommand.got oBMIns:
WordObj.Selecti on.Goto What:=wdGoToBoo kmark,
Name:=mergeCont ent(cI + 1)
WordObj.Selecti on.TypeText mergeContent(cI + 2)
cI = cI + 3
Case wordCommand.ind ent
indent.push mergeContent(cI + 1)
WordObj.Selecti on.ParagraphFor mat.LeftIndent =
WordObj.Centime tersToPoints(in dent.pop)
cI = cI + 2
Case wordCommand.ind entBack
indent.pop
WordObj.Selecti on.ParagraphFor mat.LeftIndent =
WordObj.Centime tersToPoints(in dent.pop)
cI = cI + 1
Case wordCommand.got oBM
WordObj.Selecti on.Goto What:=wdGoToBoo kmark,
Name:=mergeCont ent(cI + 1)
cI = cI + 2
Case wordCommand.ins
WordObj.Selecti on.TypeText mergeContent(cI + 1)
cI = cI + 2
Case wordCommand.ins FootNote
With WordObj.ActiveD ocument.Bookmar ks
.Add Range:=WordObj. Selection.Range , Name:="fodn"
.DefaultSorting = wdSortByName
.ShowHidden = False
End With
WordObj.ActiveD ocument.Footnot es.Add
Range:=WordObj. Selection.Range , Reference:=""
WordObj.Selecti on.TypeText mergeContent(cI + 1)
WordObj.Selecti on.Goto What:=wdGoToBoo kmark, Name:="fodn"
WordObj.Selecti on.MoveRight Unit:=wdCharact er, Count:=1
cI = cI + 2
Case Else:
'nothing
End Select
Loop Until cI > cBound
WordObj.ActiveD ocument.SaveAs fileName:=destF ile, FileFormat:= _
wdFormatDocumen t, LockComments:=F alse, Password:="",
AddToRecentFile s:= _
True, WritePassword:= "", ReadOnlyRecomme nded:=False,
EmbedTrueTypeFo nts:= _
False, SaveNativePictu reFormat:=False , SaveFormsData:= False, _
SaveAsAOCELette r:=False
DoEvents
WordObj.Activat e
Set WordObj = Nothing
DoCmd.Hourglass False
Exit Function
TemplateError:
WordObj.Quit
Set WordObj = Nothing
Exit Function
End Function
</vba_code>
The array: Mergecontent is made by retrive table content using vba. This is
specific to my use and i won't explain the table content part. I use a
function showByAnsId(ans Id%) to make Mergecontent, and the way i use it (in
a form click buttom event) is:
<vba_code>
Private Sub CWord_Click()
Dim arr
On Error Resume Next
arr = showByAnsId(Ans !id)
If oneBeyondUBound (arr) Then
MergetoWord arr
End If
End Sub
</vba_code>
Just to illustate is here the funstion.
<vba_code>
Function showByAnsId(ans Id%)
Dim rs As Recordset, bmArr(), fa$, content$, headline$
Set rs = CurrentDb.OpenR ecordset( _
"SELECT " & _
"Firma.navn , Firma.adresse, Kontakt.kontakt person, Ans.headline, "
& _
"par.abr, Par.content, Ans.id, parliste.id AS parid " & _
"FROM " & _
"firma, Jobopslag, Ans, Parliste, Par, Kontakt " & _
"WHERE " & _
"Firma.ID=Jobop slag.firma and " & _
"Jobopslag.ID=A ns.jobOpslId and " & _
"Parliste.ansId =Ans.id and " & _
"Par.id=Parlist e.parId and " & _
"Kontakt.ansId= Ans.id and " & _
"Ans.id=" & ansId & _
" order by parliste.id" _
)
If Not rs.EOF Then
fa = rs![adresse]
headline = rs![headline]
add2BookMarkLis t bmArr, _
wordCommand.got oBMIns, "firma", rs![navn], _
wordCommand.got oBMIns, "att", rs![kontaktperson], _
wordCommand.got oBMIns, "FirmaAdrL1 ", Trim$(Split(fa,
",")(0)), _
wordCommand.got oBMIns, "FirmaAdrL2 ", Trim$(Split(fa,
",")(1)), _
wordCommand.got oBMIns, "headline", rs![headline], _
wordCommand.got oBMIns, "dato", Format(Date, "d") & ". " &
MonthName(Month (Date))
End If
Dim spaceDelim$
While Not rs.EOF
If (Right$(content , 1) = ">") Or (Left$(rs![content], 1) = "<") Or
_
Len(content) = 0 Then
spaceDelim = ""
Else
spaceDelim = " ": End If
content = content & spaceDelim & rs![content]
rs.MoveNext
Wend
Dim angelBBeg%, attVal%, tag As Collection
If Len(content) Then
add2BookMarkLis t bmArr, wordCommand.got oBM, "content"
Set tag = firstTag(conten t)
While tag.item(hasTag sKey)
angelBBeg = tag.item("<")
If angelBBeg > 1 Then
add2BookMarkLis t bmArr, wordCommand.ins , Left$(content,
angelBBeg - 1): End If
Select Case tag.item(tagKey )
Case "br", "br/", "/br"
add2BookMarkLis t bmArr, wordCommand.ins , vbCrLf
Case "indent"
attVal = valOrNull(tag, "length")
If Not IsNull(attVal) Then
add2BookMarkLis t bmArr, wordCommand.ind ent, attVal:
End If
Case "/indent"
add2BookMarkLis t bmArr, wordCommand.ind entBack
Case "mailId/"
add2BookMarkLis t bmArr, wordCommand.ins FootNote, _
"From:Be******* *****@it.dk, subj:'" & headline &
"',dato:" & Left$(Now, 16)
Case Else
'nothing
End Select
content = Right$(content, Len(content) - tag.item(">"))
Set tag = Nothing
Set tag = firstTag(conten t)
Wend
If Len(content) Then
add2BookMarkLis t bmArr, wordCommand.ins , content: End If: End
If
rs.Close
Set rs = Nothing
showByAnsId = bmArr
End Function
</vba_code>
Preceding vba code has some dependency. The following is what catches my
eyes, but just ask again if you are interested and i have missed something.
<vba_code>
Const tagKey$ = "tag"
Const hasTagsKey$ = "hasTags"
Sub add2BookMarkLis t(bmArr, ParamArray bMContentPairs( ))
Dim i%
For i = 0 To UBound(bMConten tPairs)
add2list bmArr, bMContentPairs( i)
Next
End Sub
Sub add2list(V, i)
On Error GoTo Err
ReDim Preserve V(UBound(V) + 1)
V(UBound(V)) = i
Exit Sub
Err:
ReDim V(0)
Resume Next
End Sub
Function oneBeyondUBound &(Var)
On Error Resume Next
oneBeyondUBound = 1 + UBound(Var)
End Function
Function firstTag(str$) As Collection
Dim tBegP%, tEndp%, inBracket$
Dim attPairs, tagContenSpcDel Item, maxCI%, tagCI%
Set firstTag = New Collection
tBegP = InStr(str, "<")
If tBegP Then
firstTag.Add -1, hasTagsKey
tEndp = InStr(tBegP, str, ">")
If tEndp > tBegP + 1 Then
inBracket = Replace(Trim(Mi d(str, tBegP + 1, tEndp - tBegP -
1)), " ", " ")
tagContenSpcDel Item = Split(inBracket , " ")
maxCI = UBound(tagConte nSpcDelItem)
If maxCI > -1 Then
firstTag.Add tagContenSpcDel Item(0), tagKey
If maxCI > 0 Then
For tagCI = 1 To maxCI
attPairs =
Split(Replace(R eplace(tagConte nSpcDelItem(tag CI), """", ""), "'", ""), "=")
If UBound(attPairs ) = 0 Then
firstTag.Add 0, attPairs(0)
Else
firstTag.Add attPairs(1), attPairs(0): End If:
Next: End If: End If: End If
firstTag.Add tBegP, "<"
If tEndp > tBegP Then
firstTag.Add tEndp, ">": End If
Else
firstTag.Add 0, hasTagsKey: End If
End Function
</vba_code>
And finaly, my references includes 'Microsoft word 8.0 object libary' and i
use access2000 and word97
--
Regards
Benny Andersen
